From 4e5d682b4dfc1dd74b1d045f88577a7be0acc9b0 Mon Sep 17 00:00:00 2001 From: "Tarn W. Burton" Date: Thu, 26 Sep 2024 09:18:43 -0400 Subject: [PATCH] Add long-float (#1631) --- RELEASE_NOTES.md | 3 + include/clasp/core/array.fwd.h | 10 + include/clasp/core/array.h | 6 +- include/clasp/core/array_long_float.h | 111 + include/clasp/core/array_short_float.h | 113 + include/clasp/core/bignum.h | 109 +- include/clasp/core/bytecode_compiler.h | 32 +- include/clasp/core/core.h | 29 + include/clasp/core/float_util.h | 92 +- include/clasp/core/mathDispatch.h | 118 - include/clasp/core/num_co.h | 2 +- include/clasp/core/numbers.h | 1134 ++++---- include/clasp/core/object.h | 35 +- include/clasp/core/translators.h | 12 +- include/clasp/gctools/configure_memory.h | 15 +- include/clasp/gctools/gc_boot.h | 1 + include/clasp/gctools/gcarray.h | 11 +- include/clasp/gctools/pointer_tagging.h | 41 + include/clasp/gctools/smart_pointers.h | 25 +- include/clasp/gctools/tagged_cast.h | 82 +- include/clasp/llvmo/intrinsics.h | 7 +- src/analysis/clasp_gc.sif | 269 +- src/analysis/clasp_gc_cando.sif | 262 +- src/core/array.cc | 90 +- src/core/bignum.cc | 37 +- src/core/bits.cc | 4 +- src/core/bytecode.cc | 204 +- src/core/bytecode_compiler.cc | 378 ++- src/core/commonLispPackage.cc | 2 + src/core/compiler.cc | 113 +- src/core/corePackage.cc | 15 + src/core/float_to_digits.cc | 57 +- src/core/float_to_string.cc | 47 +- src/core/hashTable.cc | 14 +- src/core/lispList.cc | 10 +- src/core/lispReader.cc | 12 +- src/core/lispStream.cc | 6 +- src/core/loadltv.cc | 478 ++-- src/core/num_arith.cc | 73 +- src/core/num_co.cc | 1026 +++----- src/core/numbers.cc | 2282 ++++++++--------- src/core/numerics.cc | 78 +- src/core/pathname.cc | 2 +- src/core/primitives.cc | 24 +- src/core/random.cc | 29 +- src/core/sequence.cc | 6 +- src/core/unixfsys.cc | 13 +- src/gctools/gc_boot.cc | 1 + src/gctools/gc_interface.cc | 8 + src/gctools/mpsGarbageCollection.cc | 4 +- src/koga/config-header.lisp | 2 + src/koga/configure.lisp | 10 + src/koga/units.lisp | 6 +- src/lisp/kernel/cleavir/type.lisp | 33 +- src/lisp/kernel/cmp/bytecode-machines.lisp | 139 +- src/lisp/kernel/cmp/cmpintrinsics.lisp | 7 +- src/lisp/kernel/cmp/cmpliteral.lisp | 43 +- src/lisp/kernel/cmp/cmpltv.lisp | 270 +- src/lisp/kernel/cmp/disltv.lisp | 90 +- src/lisp/kernel/cmp/opt/opt-array.lisp | 4 + src/lisp/kernel/cmp/opt/opt-sequence.lisp | 11 +- src/lisp/kernel/cmp/opt/opt-type.lisp | 39 +- src/lisp/kernel/cmp/primitives.lisp | 16 +- src/lisp/kernel/cmp/startup-primitives.lisp | 165 +- src/lisp/kernel/lsp/fli.lisp | 3 +- src/lisp/kernel/lsp/loadltv.lisp | 99 +- src/lisp/kernel/lsp/numlib.lisp | 18 +- src/lisp/kernel/lsp/predlib.lisp | 161 +- src/lisp/regression-tests/read01.lisp | 2 +- src/llvmo/link_intrinsics.cc | 27 +- src/llvmo/llvmoExpose.cc | 8 + src/scraper/parse.lisp | 2 +- .../ansi-test-expected-failures.sexp | 2 + 73 files changed, 4946 insertions(+), 3743 deletions(-) create mode 100644 include/clasp/core/array_long_float.h create mode 100644 include/clasp/core/array_short_float.h delete mode 100644 include/clasp/core/mathDispatch.h diff --git a/RELEASE_NOTES.md b/RELEASE_NOTES.md index c538d8fd28..eb9eaf9dde 100644 --- a/RELEASE_NOTES.md +++ b/RELEASE_NOTES.md @@ -3,6 +3,9 @@ ## Added * Package lock support, based on SBCL's. Currently ignores local bindings. Thanks @bumblingbats. +* Add support for 80-bit and 128-bit LONG-FLOAT. Extended precision + LONG-FLOAT is available on amd64 and non-Apply arm64 platforms. It + is automatically detected and enabled. ## Changed * Floating point exceptions FE_INVALID, FE_OVERFLOW and FE_DIVBYZERO diff --git a/include/clasp/core/array.fwd.h b/include/clasp/core/array.fwd.h index 635516acd9..b63eb5560f 100644 --- a/include/clasp/core/array.fwd.h +++ b/include/clasp/core/array.fwd.h @@ -48,11 +48,21 @@ FORWARD(SimpleMDArrayBaseChar); FORWARD(MDArrayCharacter); FORWARD(SimpleMDArrayCharacter); // +FORWARD(SimpleVector_short_float); +FORWARD(MDArray_short_float); +FORWARD(SimpleMDArray_short_float); +FORWARD(ComplexVector_short_float); +// FORWARD(SimpleVector_double); FORWARD(MDArray_double); FORWARD(SimpleMDArray_double); FORWARD(ComplexVector_double); // +FORWARD(SimpleVector_long_float); +FORWARD(MDArray_long_float); +FORWARD(SimpleMDArray_long_float); +FORWARD(ComplexVector_long_float); +// FORWARD(SimpleVector_size_t); FORWARD(MDArray_size_t); FORWARD(SimpleMDArray_size_t); diff --git a/include/clasp/core/array.h b/include/clasp/core/array.h index 1f3c1439b1..015de32652 100644 --- a/include/clasp/core/array.h +++ b/include/clasp/core/array.h @@ -101,6 +101,8 @@ extern core::Symbol_sp& _sym_bit; extern core::Symbol_sp& _sym_float; extern core::Symbol_sp& _sym_double_float; extern core::Symbol_sp& _sym_single_float; +extern core::Symbol_sp& _sym_short_float; +extern core::Symbol_sp& _sym_long_float; extern core::Symbol_sp& _sym_UnsignedByte; extern core::Symbol_sp& _sym_T_O; extern core::Symbol_sp& _sym_simple_string; @@ -1008,8 +1010,10 @@ template cl #include #include -#include +#include #include +#include +#include #include #include #include diff --git a/include/clasp/core/array_long_float.h b/include/clasp/core/array_long_float.h new file mode 100644 index 0000000000..7734363da3 --- /dev/null +++ b/include/clasp/core/array_long_float.h @@ -0,0 +1,111 @@ +#pragma once +// ============================================================ +// Arrays specialized for long_float_t +// + +namespace core { + +FORWARD(SimpleVector_long_float); +FORWARD(MDArray_long_float); +FORWARD(SimpleMDArray_long_float); +FORWARD(ComplexVector_long_float); + +}; // namespace core + +template <> struct gctools::GCInfo { + static bool constexpr NeedsInitialization = false; + static bool constexpr NeedsFinalization = false; + static GCInfo_policy constexpr Policy = atomic; +}; + +namespace core { +class SimpleVector_long_float_O; + +typedef template_SimpleVector specialized_SimpleVector_long_float; + +class SimpleVector_long_float_O : public specialized_SimpleVector_long_float { + LISP_CLASS(core, CorePkg, SimpleVector_long_float_O, "SimpleVector_long_float", AbstractSimpleVector_O); + virtual ~SimpleVector_long_float_O() {}; + +public: + typedef specialized_SimpleVector_long_float TemplatedBase; + + static value_type default_initial_element(void) { return long_float_t{0.0}; } + static value_type from_object(T_sp obj) { return core::Number_O::as_long_float(obj.as()); }; + static T_sp to_object(const value_type& v) { return core::LongFloat_O::create(v); }; + + SimpleVector_long_float_O(size_t length, value_type initialElement = value_type(), bool initialElementSupplied = false, + size_t initialContentsSize = 0, const value_type* initialContents = NULL) + : TemplatedBase(length, initialElement, initialElementSupplied, initialContentsSize, initialContents) {}; + static smart_ptr_type make(size_t length, value_type initialElement = value_type(), bool initialElementSupplied = false, + size_t initialContentsSize = 0, const value_type* initialContents = NULL, + bool static_vector_p = false) { + auto bs = gctools::GC::allocate_container( + static_vector_p, length, initialElement, initialElementSupplied, initialContentsSize, initialContents); + return bs; + } + + virtual T_sp element_type() const override { return cl::_sym_long_float; }; + + static SimpleVector_long_float_sp create(size_t sz) { return make(sz, long_float_t{0.0}, false, 0, NULL); } + long_float_t& element(size_t i) { return this->operator[](i); }; + long_float_t& getElement(size_t i) { return this->operator[](i); }; + void setElement(size_t i, long_float_t v) { this->operator[](i) = v; }; + void addToElement(size_t i, long_float_t v) { this->operator[](i) += v; }; + void zero() { + for (size_t i(0), iEnd(this->length()); i < iEnd; ++i) + this->operator[](i) = long_float_t{0.0}; + }; + size_t size() const { return this->length(); }; +}; + +class MDArray_long_float_O + : public template_Array { + LISP_CLASS(core, CorePkg, MDArray_long_float_O, "MDArray_long_float", MDArray_O); + virtual ~MDArray_long_float_O() {}; + +public: + typedef template_Array TemplatedBase; + + MDArray_long_float_O(size_t rank, List_sp dimensions, Array_sp data, bool displacedToP, Fixnum_sp displacedIndexOffset) + : TemplatedBase(rank, dimensions, data, displacedToP, displacedIndexOffset) {}; +}; + +class SimpleMDArray_long_float_O + : public template_SimpleArray { + LISP_CLASS(core, CorePkg, SimpleMDArray_long_float_O, "SimpleMDArray_long_float", SimpleMDArray_O); + virtual ~SimpleMDArray_long_float_O() {}; + +public: + typedef template_SimpleArray TemplatedBase; + + SimpleMDArray_long_float_O(size_t rank, List_sp dimensions, Array_sp data) : TemplatedBase(rank, dimensions, data) {}; +}; + +class ComplexVector_long_float_O : public template_Vector { + LISP_CLASS(core, CorePkg, ComplexVector_long_float_O, "ComplexVector_long_float", ComplexVector_O); + virtual ~ComplexVector_long_float_O() {}; + +public: + typedef template_Vector TemplatedBase; + + ComplexVector_long_float_O(size_t rank1, size_t dimension, T_sp fillPointer, Array_sp data, bool displacedToP, + Fixnum_sp displacedIndexOffset) + : TemplatedBase(dimension, fillPointer, data, displacedToP, displacedIndexOffset) {}; + static smart_ptr_type make_vector(size_t dimension, simple_element_type initialElement /*=simple_element_type()*/, + T_sp fillPointer /*=_Nil()*/, T_sp dataOrDisplacedTo /*=_Nil()*/, + bool displacedToP /*=false*/, Fixnum_sp displacedIndexOffset /*=clasp_make_fixnum(0)*/) { + LIKELY_if(dataOrDisplacedTo.nilp()) dataOrDisplacedTo = simple_type::make(dimension, initialElement, true); + return gctools::GC::allocate_container( + false, 1 /*CRANK*/, dimension, fillPointer, gc::As_unsafe(dataOrDisplacedTo), displacedToP, displacedIndexOffset); + } + static smart_ptr_type make_vector(size_t dimension) { + return make_vector(dimension, 0, nil(), nil(), false, clasp_make_fixnum(0)); + } + static smart_ptr_type make(size_t dimension, simple_element_type initialElement, bool initialElementSuppliedP, T_sp fillPointer, + T_sp dataOrDisplacedTo, bool displacedToP, Fixnum_sp displacedIndexOffset) { + (void)initialElementSuppliedP; + return make_vector(dimension, initialElement, fillPointer, dataOrDisplacedTo, displacedToP, displacedIndexOffset); + } +}; +}; // namespace core diff --git a/include/clasp/core/array_short_float.h b/include/clasp/core/array_short_float.h new file mode 100644 index 0000000000..6b19b4e4d4 --- /dev/null +++ b/include/clasp/core/array_short_float.h @@ -0,0 +1,113 @@ +#pragma once +// ============================================================ +// Arrays specialized for short_float_t +// + +namespace core { + +FORWARD(SimpleVector_short_float); +FORWARD(MDArray_short_float); +FORWARD(SimpleMDArray_short_float); +FORWARD(ComplexVector_short_float); + +}; // namespace core + +template <> struct gctools::GCInfo { + static bool constexpr NeedsInitialization = false; + static bool constexpr NeedsFinalization = false; + static GCInfo_policy constexpr Policy = atomic; +}; + +namespace core { +class SimpleVector_short_float_O; + +typedef template_SimpleVector + specialized_SimpleVector_short_float; + +class SimpleVector_short_float_O : public specialized_SimpleVector_short_float { + LISP_CLASS(core, CorePkg, SimpleVector_short_float_O, "SimpleVector_short_float", AbstractSimpleVector_O); + virtual ~SimpleVector_short_float_O() {}; + +public: + typedef specialized_SimpleVector_short_float TemplatedBase; + + static value_type default_initial_element(void) { return short_float_t{0.0}; } + static value_type from_object(T_sp obj) { return core::Number_O::as_short_float(obj.as()); }; + static T_sp to_object(const value_type& v) { return core::ShortFloat_O::create(v); }; + + SimpleVector_short_float_O(size_t length, value_type initialElement = value_type(), bool initialElementSupplied = false, + size_t initialContentsSize = 0, const value_type* initialContents = NULL) + : TemplatedBase(length, initialElement, initialElementSupplied, initialContentsSize, initialContents) {}; + static smart_ptr_type make(size_t length, value_type initialElement = value_type(), bool initialElementSupplied = false, + size_t initialContentsSize = 0, const value_type* initialContents = NULL, + bool static_vector_p = false) { + auto bs = gctools::GC::allocate_container( + static_vector_p, length, initialElement, initialElementSupplied, initialContentsSize, initialContents); + return bs; + } + + virtual T_sp element_type() const override { return cl::_sym_short_float; }; + + static SimpleVector_short_float_sp create(size_t sz) { return make(sz, short_float_t{0.0}, false, 0, NULL); } + short_float_t& element(size_t i) { return this->operator[](i); }; + short_float_t& getElement(size_t i) { return this->operator[](i); }; + void setElement(size_t i, short_float_t v) { this->operator[](i) = v; }; + void addToElement(size_t i, short_float_t v) { this->operator[](i) += v; }; + void zero() { + for (size_t i(0), iEnd(this->length()); i < iEnd; ++i) + this->operator[](i) = short_float_t{0.0}; + }; + size_t size() const { return this->length(); }; +}; + +class MDArray_short_float_O + : public template_Array { + LISP_CLASS(core, CorePkg, MDArray_short_float_O, "MDArray_short_float", MDArray_O); + virtual ~MDArray_short_float_O() {}; + +public: + typedef template_Array TemplatedBase; + + MDArray_short_float_O(size_t rank, List_sp dimensions, Array_sp data, bool displacedToP, Fixnum_sp displacedIndexOffset) + : TemplatedBase(rank, dimensions, data, displacedToP, displacedIndexOffset) {}; +}; + +class SimpleMDArray_short_float_O + : public template_SimpleArray { + LISP_CLASS(core, CorePkg, SimpleMDArray_short_float_O, "SimpleMDArray_short_float", SimpleMDArray_O); + virtual ~SimpleMDArray_short_float_O() {}; + +public: + typedef template_SimpleArray TemplatedBase; + + SimpleMDArray_short_float_O(size_t rank, List_sp dimensions, Array_sp data) : TemplatedBase(rank, dimensions, data) {}; +}; + +class ComplexVector_short_float_O + : public template_Vector { + LISP_CLASS(core, CorePkg, ComplexVector_short_float_O, "ComplexVector_short_float", ComplexVector_O); + virtual ~ComplexVector_short_float_O() {}; + +public: + typedef template_Vector TemplatedBase; + + ComplexVector_short_float_O(size_t rank1, size_t dimension, T_sp fillPointer, Array_sp data, bool displacedToP, + Fixnum_sp displacedIndexOffset) + : TemplatedBase(dimension, fillPointer, data, displacedToP, displacedIndexOffset) {}; + static smart_ptr_type make_vector(size_t dimension, simple_element_type initialElement /*=simple_element_type()*/, + T_sp fillPointer /*=_Nil()*/, T_sp dataOrDisplacedTo /*=_Nil()*/, + bool displacedToP /*=false*/, Fixnum_sp displacedIndexOffset /*=clasp_make_fixnum(0)*/) { + LIKELY_if(dataOrDisplacedTo.nilp()) dataOrDisplacedTo = simple_type::make(dimension, initialElement, true); + return gctools::GC::allocate_container( + false, 1 /*CRANK*/, dimension, fillPointer, gc::As_unsafe(dataOrDisplacedTo), displacedToP, displacedIndexOffset); + } + static smart_ptr_type make_vector(size_t dimension) { + return make_vector(dimension, 0, nil(), nil(), false, clasp_make_fixnum(0)); + } + static smart_ptr_type make(size_t dimension, simple_element_type initialElement, bool initialElementSuppliedP, T_sp fillPointer, + T_sp dataOrDisplacedTo, bool displacedToP, Fixnum_sp displacedIndexOffset) { + (void)initialElementSuppliedP; + return make_vector(dimension, initialElement, fillPointer, dataOrDisplacedTo, displacedToP, displacedIndexOffset); + } +}; +}; // namespace core diff --git a/include/clasp/core/bignum.h b/include/clasp/core/bignum.h index 5017d2efa2..ad69f2a065 100644 --- a/include/clasp/core/bignum.h +++ b/include/clasp/core/bignum.h @@ -33,6 +33,19 @@ THE SOFTWARE. #include // integral namespace core { + +template +concept unsigned_limb = std::is_integral::value && std::is_unsigned::value && sizeof(T) <= sizeof(mp_limb_t); + +template +concept unsigned_limbs = std::is_integral::value && std::is_unsigned::value && sizeof(T) > sizeof(mp_limb_t); + +template +concept signed_limb = std::is_integral::value && std::is_signed::value && sizeof(T) <= sizeof(mp_limb_t); + +template +concept signed_limbs = std::is_integral::value && std::is_signed::value && sizeof(T) > sizeof(mp_limb_t); + class Bignum_O; }; @@ -69,35 +82,55 @@ class Bignum_O : public Integer_O { return b; }; static Bignum_sp create(const mpz_class&); - static Bignum_sp create(gc::Fixnum fix) { return create_from_limbs((fix < 0) ? -1 : 1, std::abs(fix), true); } -#if !defined(CLASP_UNSIGNED_LONG_LONG_IS_UINT64) - static Bignum_sp create(unsigned long long ull) { - ASSERT(sizeof(unsigned long long) <= sizeof(mp_limb_t)); - return create_from_limbs(1, ull, true); + + template static Bignum_sp create(T v) { + Bignum_sp b = create_from_limbs(1); + b->_limbs[0] = v; + return b; } -#endif -#if !defined(CLASP_LONG_LONG_IS_INT64) - static Bignum_sp create(long long ll) { - ASSERT(sizeof(long long) <= sizeof(mp_limb_t)); - return create_from_limbs((ll < 0) ? -1 : 1, std::abs(ll), true); + + template static Bignum_sp create(T v) { + Bignum_sp b = create_from_limbs((v < 0) ? -1 : 1); + b->_limbs[0] = std::abs(v); + return b; } -#endif -#if !defined(CLASP_FIXNUM_IS_INT64) - static Bignum_sp create(int64_t v) { return create_from_limbs((v < 0) ? -1 : 1, std::abs(v), true); } -#endif - static Bignum_sp create(uint64_t v) { return create_from_limbs(1, v, true); } - static Bignum_sp create(__uint128_t v) { - Bignum_sp b = create_from_limbs(2); - b->_limbs[0] = static_cast(v); - b->_limbs[1] = static_cast(v >> 64); + + template static Bignum_sp create(T v) { + constexpr size_t limb_width = CHAR_BIT * sizeof(mp_limb_t); + size_t len = (std::bit_width(v) + limb_width - 1) / limb_width; + Bignum_sp b = create_from_limbs(len); + + for (size_t i = 0; i < len; i++) { + b->_limbs[i] = static_cast(v); + v = v >> limb_width; + } + return b; } - static Bignum_sp create(double d) { - // KLUDGE: there is no mpn function for converting from a double. - // However, this conses, which we shouldn't need to do. - mpz_class rop; - mpz_set_d(rop.get_mpz_t(), d); - return create(rop); + + template static Bignum_sp create(T v) { + constexpr size_t limb_width = CHAR_BIT * sizeof(mp_limb_t); + using UT = typename std::make_unsigned::type; + bool negative = v < 0; + UT w = std::abs(v); + size_t len = (std::bit_width(w) + limb_width - 1) / limb_width; + Bignum_sp b = create_from_limbs(negative ? -len : len); + + for (size_t i = 0; i < len; i++) { + b->_limbs[i] = static_cast(w); + w = w >> limb_width; + } + + return b; + } + + template static Bignum_sp create(Float v) { + auto q = float_convert::float_to_quadruple(v); + Bignum_sp b = gc::As_unsafe(clasp_ash(create(q.significand), q.exponent)) ; + if (q.sign < 0) + return gc::As_unsafe(clasp_negate(b)); + + return b; } static Bignum_sp make(const string& value_in_string); @@ -121,10 +154,11 @@ class Bignum_O : public Integer_O { Number_sp log1_() const override; Number_sp sqrt_() const override; Number_sp reciprocal_() const override; - Rational_sp rational_() const final { return this->asSmartPtr(); }; - virtual float as_float_() const override; - virtual double as_double_() const override; - virtual LongFloat as_long_float_() const override; + Rational_sp as_rational_() const override { return this->asSmartPtr(); }; + virtual short_float_t as_short_float_() const override; + virtual single_float_t as_single_float_() const override; + virtual double as_double_float_() const override; + virtual long_float_t as_long_float_() const override; virtual bool zerop_() const override { return false; } virtual bool plusp_() const override { return (this->length() > 0); } @@ -194,20 +228,14 @@ class Bignum_O : public Integer_O { Bignum_sp core__next_from_fixnum(Fixnum); Integer_sp bignum_result(mp_size_t, const mp_limb_t*); -Integer_sp core__next_fmul(Bignum_sp, Fixnum); -Bignum_sp core__next_mul(Bignum_sp, Bignum_sp); Bignum_sp core__mul_fixnums(Fixnum, Fixnum); Bignum_sp core__next_lshift(Bignum_sp, Fixnum); Integer_sp core__next_rshift(Bignum_sp, Fixnum); -T_mv core__next_truncate(Bignum_sp, Bignum_sp); +Number_mv core__next_truncate(Bignum_sp, Bignum_sp); Integer_sp fix_divided_by_next(Fixnum, Bignum_sp); -T_mv core__next_ftruncate(Bignum_sp, Fixnum); +Number_mv core__next_ftruncate(Bignum_sp, Fixnum); Integer_sp core__next_gcd(Bignum_sp, Bignum_sp); Integer_sp core__next_fgcd(Bignum_sp, Fixnum); -Integer_sp core__next_add(Bignum_sp, Bignum_sp); -Integer_sp core__next_sub(Bignum_sp, Bignum_sp); -Integer_sp core__next_fadd(Bignum_sp, Fixnum); -Integer_sp core__next_fsub(Fixnum, Bignum_sp); int core__next_compare(Bignum_sp, Bignum_sp); template integral clasp_to_integral(T_sp obj) { @@ -227,4 +255,11 @@ template integral clasp_to_integral(T_sp obj) { TYPE_ERROR(obj, Cons_O::createList(cl::_sym_Integer_O, Integer_O::create(mn), Integer_O::create(mx))); }; +template Integer_sp Integer_O::create(Float v) { + if (v >= static_cast(gc::most_negative_fixnum) && v < static_cast(gc::most_positive_fixnum)) + return clasp_make_fixnum(v); + else + return Bignum_O::create(v); +} + }; // namespace core diff --git a/include/clasp/core/bytecode_compiler.h b/include/clasp/core/bytecode_compiler.h index 4ec36268c6..5adf64a8fa 100644 --- a/include/clasp/core/bytecode_compiler.h +++ b/include/clasp/core/bytecode_compiler.h @@ -4,6 +4,10 @@ #include #include +#define VM_CODES +#include +#undef VM_CODES + namespace comp { using namespace core; @@ -463,10 +467,10 @@ class Context { size_t env_index() const; size_t closure_index(T_sp info) const; void push_debug_info(T_sp info) const; - void assemble0(uint8_t opcode) const; - void assemble1(uint8_t opcode, size_t operand1) const; - void assemble2(uint8_t opcode, size_t operand1, size_t operand2) const; - void emit_control_label(Label_sp, uint8_t opcode8, uint8_t opcode16, uint8_t opcode24) const; + void assemble0(vm_code opcode) const; + void assemble1(vm_code opcode, size_t operand1) const; + void assemble2(vm_code opcode, size_t operand1, size_t operand2) const; + void emit_control_label(Label_sp, vm_code opcode8, vm_code opcode16, vm_code opcode24) const; void emit_jump(Label_sp label) const; void emit_jump_if(Label_sp label) const; void emit_entry_or_save_sp(LexicalInfo_sp info) const; @@ -612,16 +616,16 @@ class ControlLabelFixup_O : public LabelFixup_O { LISP_CLASS(comp, CompPkg, ControlLabelFixup_O, "ControlLabelFixup", LabelFixup_O); public: - uint8_t _opcode8; - uint8_t _opcode16; - uint8_t _opcode24; + vm_code _opcode8; + vm_code _opcode16; + vm_code _opcode24; public: - ControlLabelFixup_O(Label_sp label, uint8_t opcode8, uint8_t opcode16, uint8_t opcode24) - : LabelFixup_O(label, 2), _opcode8(opcode8), _opcode16(opcode16), _opcode24(opcode24) {} + ControlLabelFixup_O(Label_sp label, vm_code opcode8, vm_code opcode16, vm_code opcode24) + : LabelFixup_O(label, 2), _opcode8(opcode8), _opcode16(opcode16), _opcode24(opcode24) {} CL_LISPIFY_NAME(ControlLabelFixup/make) CL_DEF_CLASS_METHOD - static ControlLabelFixup_sp make(Label_sp label, uint8_t opcode8, uint8_t opcode16, uint8_t opcode24) { + static ControlLabelFixup_sp make(Label_sp label, vm_code opcode8, vm_code opcode16, vm_code opcode24) { return gctools::GC::allocate(label, opcode8, opcode16, opcode24); } @@ -673,19 +677,19 @@ class LexRefFixup_O : public LexFixup_O { LISP_CLASS(comp, CompPkg, LexRefFixup_O, "LexRefFixup", LexFixup_O); public: - uint8_t _opcode; + vm_code _opcode; public: LexRefFixup_O() : LexFixup_O() {} - LexRefFixup_O(LexicalInfo_sp lex, uint8_t opcode) : LexFixup_O(lex, 0), _opcode(opcode) {} + LexRefFixup_O(LexicalInfo_sp lex, vm_code opcode) : LexFixup_O(lex, 0), _opcode(opcode) {} CL_LISPIFY_NAME(LexRefFixup/make) CL_DEF_CLASS_METHOD - static LexRefFixup_sp make(LexicalInfo_sp lex, uint8_t opcode) { + static LexRefFixup_sp make(LexicalInfo_sp lex, vm_code opcode) { return gctools::GC::allocate(lex, opcode); } public: - uint8_t opcode() { return this->_opcode; } + vm_code opcode() { return this->_opcode; } virtual void emit(size_t position, SimpleVector_byte8_t_sp code); virtual size_t resize(); }; diff --git a/include/clasp/core/core.h b/include/clasp/core/core.h index d45822590a..096e2f2da4 100644 --- a/include/clasp/core/core.h +++ b/include/clasp/core/core.h @@ -52,6 +52,35 @@ THE SOFTWARE. //#define USE_MPS //#endif +#include + +namespace core { + +#ifdef USE_SHORT_FLOAT +#define CLASP_SHORT_FLOAT +#define CLASP_SHORT_FLOAT_BINARY16 +typedef _Float16 short_float_t; +#else +typedef float short_float_t; +#endif + +typedef float single_float_t; + +typedef double double_float_t; + +#if defined(USE_LONG_FLOAT) && LDBL_MANT_DIG == 64 +#define CLASP_LONG_FLOAT +#define CLASP_LONG_FLOAT_BINARY80 +typedef long double long_float_t; +#elif defined(USE_LONG_FLOAT) && LDBL_MANT_DIG == 113 +#define CLASP_LONG_FLOAT +#define CLASP_LONG_FLOAT_BINARY128 +typedef long double long_float_t; +#else +typedef double long_float_t; +#endif +}; + /*! Old way of doing #= and ## used alists which are slow Switch to hash-tables to speed things up */ #define USE_SHARP_EQUAL_HASH_TABLES 1 diff --git a/include/clasp/core/float_util.h b/include/clasp/core/float_util.h index 08387caecb..524fef3a77 100644 --- a/include/clasp/core/float_util.h +++ b/include/clasp/core/float_util.h @@ -4,14 +4,14 @@ namespace core { -template struct float_convert { - static constexpr uint16_t significand_width = std::numeric_limits::digits; - static constexpr uint16_t exponent_width = std::bit_width((unsigned int)std::numeric_limits::max_exponent); +template struct float_traits { + static constexpr uint16_t exponent_width = ExponentWidth; + static constexpr uint16_t significand_width = SignificandWidth; static constexpr uint16_t sign_width = 1; static constexpr bool has_hidden_bit = ((sign_width + exponent_width + significand_width) % 8) != 0; static constexpr uint16_t storage_width = sign_width + exponent_width + significand_width + ((has_hidden_bit) ? -1 : 0); - static constexpr int32_t exponent_bias = std::numeric_limits::max_exponent + significand_width - 2; - static constexpr int32_t max_exponent = std::numeric_limits::max_exponent - significand_width; + static constexpr int32_t exponent_bias = (1 << (exponent_width - 1)) + significand_width - 2; + static constexpr int32_t max_exponent = (1 << (exponent_width - 1)) - significand_width; static constexpr int32_t min_exponent = 2 - exponent_bias - significand_width; static constexpr int32_t min_normalized_exponent = 1 - exponent_bias; using uint_t = @@ -28,56 +28,61 @@ template struct float_convert { static constexpr uint_t exponent_mask = ((uint_t{1} << exponent_width) - uint_t{1}) << exponent_shift; static constexpr uint_t sign_mask = ((uint_t{1} << sign_width) - uint_t{1}) << sign_shift; static constexpr uint_t nan_type_mask = uint_t{1} << (significand_width + ((has_hidden_bit) ? -2 : -1)); +}; +template struct float_convert { + using traits = + float_traits::max_exponent), std::numeric_limits::digits>; + using uint_t = typename traits::uint_t; enum class category { finite, quiet_nan, signaling_nan, infinity }; typedef union { Float f; - uint_t b; + unsigned _BitInt(traits::storage_width) b; } convert_t; - static inline uint_t to_bits(Float f) { + static inline uint_t float_to_bits(Float f) { convert_t convert = {.f = f}; - return convert.b; + return uint_t{convert.b}; } - static inline Float from_bits(uint_t b) { + static inline Float bits_to_float(uint_t b) { convert_t convert = {.b = b}; return convert.f; } struct quadruple { category category; - uint_t significand; + __uint128_t significand; int32_t exponent; int16_t sign; }; - static quadruple to_quadruple(Float f) { + template + static quadruple bits_to_quadruple(typename Traits::uint_t b) { quadruple q; - uint_t b = to_bits(f); - q.significand = b & significand_mask; - q.exponent = static_cast((b & exponent_mask) >> exponent_shift); - q.sign = (b & sign_mask) ? int32_t{-1} : int32_t{1}; + q.significand = b & Traits::significand_mask; + q.exponent = static_cast((b & Traits::exponent_mask) >> Traits::exponent_shift); + q.sign = (b & Traits::sign_mask) ? int32_t{-1} : int32_t{1}; - if (q.exponent != non_finite_exponent) { + if (q.exponent != Traits::non_finite_exponent) { q.category = category::finite; if (q.exponent != 0) { // Normal non-zero - q.significand |= hidden_bit; - q.exponent -= exponent_bias; + q.significand |= Traits::hidden_bit; + q.exponent -= Traits::exponent_bias; } else if (q.significand != 0) { // Subnormal - int32_t shift = significand_width - std::bit_width(q.significand); + int32_t shift = Traits::significand_width - std::bit_width(q.significand); q.significand = q.significand << shift; - q.exponent = 1 - exponent_bias - shift; + q.exponent = 1 - Traits::exponent_bias - shift; } } else if (q.significand == 0) { q.category = category::infinity; - } else if (q.significand & nan_type_mask) { + } else if (q.significand & Traits::nan_type_mask) { q.category = category::quiet_nan; - q.significand &= ~nan_type_mask; + q.significand &= ~Traits::nan_type_mask; } else { q.category = category::signaling_nan; } @@ -85,27 +90,28 @@ template struct float_convert { return q; } - static Float from_quadruple(quadruple q) { - uint_t b = 0; + template + static typename Traits::uint_t quadruple_to_bits(quadruple q) { + typename Traits::uint_t b = 0; if (q.sign < 0) - b |= sign_mask; + b |= Traits::sign_mask; switch (q.category) { case category::infinity: - b |= exponent_mask; + b |= Traits::exponent_mask; break; case category::quiet_nan: - b |= exponent_mask | nan_type_mask | (q.significand & payload_mask); + b |= Traits::exponent_mask | Traits::nan_type_mask | (q.significand & Traits::payload_mask); break; case category::signaling_nan: - b |= exponent_mask | ((q.significand == 0) ? uint_t{1} : (q.significand & payload_mask)); + b |= Traits::exponent_mask | ((q.significand == 0) ? uint_t{1} : (q.significand & Traits::payload_mask)); break; default: if (q.significand != 0) { - uint_t significand = q.significand; + __uint128_t significand = q.significand; int32_t exponent = q.exponent; - int32_t shift = std::bit_width(significand) - significand_width; + int32_t shift = std::bit_width(significand) - Traits::significand_width; // If we don't have enough bits then right shift. if (shift < 0) { @@ -115,15 +121,15 @@ template struct float_convert { } // Check for subnormals and set the shift needed to normalize. - if ((exponent + shift) < min_normalized_exponent) { - shift = min_normalized_exponent - exponent; + if ((exponent + shift) < Traits::min_normalized_exponent) { + shift = Traits::min_normalized_exponent - exponent; } // If we shift away all of the bits that is an underflow. if (shift > std::bit_width(significand)) { feraiseexcept(FE_UNDERFLOW); // Return +/- zero if traps masked. - return from_bits(b); + return b; } // Round if we have extra bits. @@ -135,31 +141,35 @@ template struct float_convert { } // Check one more time to ensure rounding hasn't increased the width. - shift = std::max(static_cast(std::bit_width(significand) - significand_width), 0); + shift = std::max(static_cast(std::bit_width(significand) - Traits::significand_width), 0); significand = significand >> shift; exponent += shift; // Check for overflow. - if (exponent > max_exponent) { + if (exponent > Traits::max_exponent) { feraiseexcept(FE_OVERFLOW); // Return +/- infinity if traps masked. - return from_bits(b | exponent_mask); + return b | Traits::exponent_mask; } - if (std::bit_width(significand) < significand_width) { + if (std::bit_width(significand) < Traits::significand_width) { // Subnormals - b |= significand & significand_mask; + b |= significand & Traits::significand_mask; } else { // Normal - b |= (significand & significand_mask) | - ((static_cast(exponent + exponent_bias) << exponent_shift) & exponent_mask); + b |= (significand & Traits::significand_mask) | + ((static_cast(exponent + Traits::exponent_bias) << Traits::exponent_shift) & Traits::exponent_mask); } } break; } - return from_bits(b); + return b; }; + + inline static Float quadruple_to_float(quadruple q) { return bits_to_float(quadruple_to_bits(q)); } + + inline static quadruple float_to_quadruple(Float f) { return bits_to_quadruple(float_to_bits(f)); } }; } // namespace core diff --git a/include/clasp/core/mathDispatch.h b/include/clasp/core/mathDispatch.h deleted file mode 100644 index 9c237e8ee4..0000000000 --- a/include/clasp/core/mathDispatch.h +++ /dev/null @@ -1,118 +0,0 @@ -#pragma once -/* - File: mathDispatch.h -*/ - -/* -Copyright (c) 2014, Christian E. Schafmeister - -CLASP is free software; you can redistribute it and/or -modify it under the terms of the GNU Library General Public -License as published by the Free Software Foundation; either -version 2 of the License, or (at your option) any later version. - -See directory 'clasp/licenses' for full details. - -The above copyright notice and this permission notice shall be included in -all copies or substantial portions of the Software. - -THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR -IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY, -FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE -AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER -LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, -OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN -THE SOFTWARE. -*/ -/* -^- */ - -// -// Macros to assist in dispatching for mathematical operations between mixed types -// -// These macros closely follow the approach used by ECL -// in math_dispatch2.h -// -// -#define MATH_DISPATCH_BEGIN(a, b) \ - { \ - int ta = (int)(clasp_t_of(a)); \ - int tb = (int)(clasp_t_of(b)); \ - int dispatch_combo = ta * (number_NUM) + tb; \ - switch (dispatch_combo) - -#define MDL(na, nb) ((int)(na) * (int)(number_NUM) + (int)(nb)) -#define case_Fixnum_v_Fixnum case MDL(number_Fixnum, number_Fixnum) -#define case_Fixnum_v_Bignum case MDL(number_Fixnum, number_Bignum) -#define case_Fixnum_v_ShortFloat case MDL(number_Fixnum, number_ShortFloat) -#define case_Fixnum_v_SingleFloat case MDL(number_Fixnum, number_SingleFloat) -#define case_Fixnum_v_DoubleFloat case MDL(number_Fixnum, number_DoubleFloat) -#define case_Fixnum_v_LongFloat case MDL(number_Fixnum, number_LongFloat) -#define case_Fixnum_v_Ratio case MDL(number_Fixnum, number_Ratio) -#define case_Fixnum_v_Complex case MDL(number_Fixnum, number_Complex) - -#define case_Bignum_v_Fixnum case MDL(number_Bignum, number_Fixnum) -#define case_Bignum_v_Bignum case MDL(number_Bignum, number_Bignum) -#define case_Bignum_v_ShortFloat case MDL(number_Bignum, number_ShortFloat) -#define case_Bignum_v_SingleFloat case MDL(number_Bignum, number_SingleFloat) -#define case_Bignum_v_DoubleFloat case MDL(number_Bignum, number_DoubleFloat) -#define case_Bignum_v_LongFloat case MDL(number_Bignum, number_LongFloat) -#define case_Bignum_v_Ratio case MDL(number_Bignum, number_Ratio) -#define case_Bignum_v_Complex case MDL(number_Bignum, number_Complex) - -#define case_ShortFloat_v_Fixnum case MDL(number_ShortFloat, number_Fixnum) -#define case_ShortFloat_v_Bignum case MDL(number_ShortFloat, number_Bignum) -#define case_ShortFloat_v_ShortFloat case MDL(number_ShortFloat, number_ShortFloat) -#define case_ShortFloat_v_SingleFloat case MDL(number_ShortFloat, number_SingleFloat) -#define case_ShortFloat_v_DoubleFloat case MDL(number_ShortFloat, number_DoubleFloat) -#define case_ShortFloat_v_LongFloat case MDL(number_ShortFloat, number_LongFloat) -#define case_ShortFloat_v_Ratio case MDL(number_ShortFloat, number_Ratio) -#define case_ShortFloat_v_Complex case MDL(number_ShortFloat, number_Complex) - -#define case_SingleFloat_v_Fixnum case MDL(number_SingleFloat, number_Fixnum) -#define case_SingleFloat_v_Bignum case MDL(number_SingleFloat, number_Bignum) -#define case_SingleFloat_v_ShortFloat case MDL(number_SingleFloat, number_ShortFloat) -#define case_SingleFloat_v_SingleFloat case MDL(number_SingleFloat, number_SingleFloat) -#define case_SingleFloat_v_DoubleFloat case MDL(number_SingleFloat, number_DoubleFloat) -#define case_SingleFloat_v_LongFloat case MDL(number_SingleFloat, number_LongFloat) -#define case_SingleFloat_v_Ratio case MDL(number_SingleFloat, number_Ratio) -#define case_SingleFloat_v_Complex case MDL(number_SingleFloat, number_Complex) - -#define case_DoubleFloat_v_Fixnum case MDL(number_DoubleFloat, number_Fixnum) -#define case_DoubleFloat_v_Bignum case MDL(number_DoubleFloat, number_Bignum) -#define case_DoubleFloat_v_ShortFloat case MDL(number_DoubleFloat, number_ShortFloat) -#define case_DoubleFloat_v_SingleFloat case MDL(number_DoubleFloat, number_SingleFloat) -#define case_DoubleFloat_v_DoubleFloat case MDL(number_DoubleFloat, number_DoubleFloat) -#define case_DoubleFloat_v_LongFloat case MDL(number_DoubleFloat, number_LongFloat) -#define case_DoubleFloat_v_Ratio case MDL(number_DoubleFloat, number_Ratio) -#define case_DoubleFloat_v_Complex case MDL(number_DoubleFloat, number_Complex) - -#define case_LongFloat_v_Fixnum case MDL(number_LongFloat, number_Fixnum) -#define case_LongFloat_v_Bignum case MDL(number_LongFloat, number_Bignum) -#define case_LongFloat_v_ShortFloat case MDL(number_LongFloat, number_ShortFloat) -#define case_LongFloat_v_SingleFloat case MDL(number_LongFloat, number_SingleFloat) -#define case_LongFloat_v_DoubleFloat case MDL(number_LongFloat, number_DoubleFloat) -#define case_LongFloat_v_LongFloat case MDL(number_LongFloat, number_LongFloat) -#define case_LongFloat_v_Ratio case MDL(number_LongFloat, number_Ratio) -#define case_LongFloat_v_Complex case MDL(number_LongFloat, number_Complex) - -#define case_Ratio_v_Fixnum case MDL(number_Ratio, number_Fixnum) -#define case_Ratio_v_Bignum case MDL(number_Ratio, number_Bignum) -#define case_Ratio_v_ShortFloat case MDL(number_Ratio, number_ShortFloat) -#define case_Ratio_v_SingleFloat case MDL(number_Ratio, number_SingleFloat) -#define case_Ratio_v_DoubleFloat case MDL(number_Ratio, number_DoubleFloat) -#define case_Ratio_v_LongFloat case MDL(number_Ratio, number_LongFloat) -#define case_Ratio_v_Ratio case MDL(number_Ratio, number_Ratio) -#define case_Ratio_v_Complex case MDL(number_Ratio, number_Complex) - -#define case_Complex_v_Fixnum case MDL(number_Complex, number_Fixnum) -#define case_Complex_v_Bignum case MDL(number_Complex, number_Bignum) -#define case_Complex_v_ShortFloat case MDL(number_Complex, number_ShortFloat) -#define case_Complex_v_SingleFloat case MDL(number_Complex, number_SingleFloat) -#define case_Complex_v_DoubleFloat case MDL(number_Complex, number_DoubleFloat) -#define case_Complex_v_LongFloat case MDL(number_Complex, number_LongFloat) -#define case_Complex_v_Ratio case MDL(number_Complex, number_Ratio) -#define case_Complex_v_Complex case MDL(number_Complex, number_Complex) - -#define MATH_DISPATCH_END() \ - } \ - ; diff --git a/include/clasp/core/num_co.h b/include/clasp/core/num_co.h index b432f71bf3..78eb93c22a 100644 --- a/include/clasp/core/num_co.h +++ b/include/clasp/core/num_co.h @@ -33,7 +33,7 @@ namespace core { Float_sp cl__float(Real_sp x, T_sp y); Real_mv cl__integer_decode_float(Float_sp x); -int clasp_signbit(Number_sp x); +bool clasp_signbit(Number_sp x); Integer_sp cl__numerator(Rational_sp r); Integer_sp cl__denominator(Rational_sp r); diff --git a/include/clasp/core/numbers.h b/include/clasp/core/numbers.h index 963d8e4e77..3cd830a291 100644 --- a/include/clasp/core/numbers.h +++ b/include/clasp/core/numbers.h @@ -31,6 +31,8 @@ #include #include #include +#include +#include #pragma GCC diagnostic push // #pragma GCC diagnostic ignored "-Wunused-local-typedef" #pragma GCC diagnostic pop @@ -41,25 +43,20 @@ #include // Class Hierarchy -// Number_0 +// Number_0 [n] // Real_O // Rational_O // Integer_O -// Fixnum_dummy_O (immediate) -// Bignum_O +// Fixnum_dummy_O (immediate) [x] +// Bignum_O [b] // Ratio_O // Float_O -// ShortFloat_O -// SingleFloat_dummy_O (immediate) -// DoubleFloat_O -// LongFloat_O +// ShortFloat_O [s] +// SingleFloat_dummy_O (immediate) [f] +// DoubleFloat_O [d] +// LongFloat_O [l] // Complex_O -#define CLASP_PI_D 3.14159265358979323846264338327950288 -#define CLASP_PI_L 3.14159265358979323846264338327950288l -#define CLASP_PI2_D 1.57079632679489661923132169163975144 -#define CLASP_PI2_L 1.57079632679489661923132169163975144l - #ifdef _TARGET_OS_DARWIN #if defined(__aarch64__) @@ -130,27 +127,13 @@ inline int fegetexcept() { namespace cl { extern core::Symbol_sp& _sym_Integer_O; // CL:INTEGER extern core::Symbol_sp& _sym_Real_O; // CL:INTEGER -}; // namespace cl +}; // namespace cl namespace core { // TYPE ERRORS core::Fixnum not_fixnum_error(core::T_sp o); -// TYPE IDS - -typedef enum { - number_Fixnum = 0, - number_Bignum = 1, - number_Ratio = 2, - number_ShortFloat = 3, - number_SingleFloat = 4, - number_DoubleFloat = 5, - number_LongFloat = 6, - number_Complex = 7, - number_NUM = 8 -} NumberType; - // TYPE TEMPLATES template gc::smart_ptr immediate_fixnum(Fixnum f) { return gc::make_tagged_fixnum(f); }; @@ -158,47 +141,17 @@ template gc::smart_ptr immediate_single_float(float f) { return gc::make_tagged_single_float(f); }; -template inline FLOAT _log1p(FLOAT x) { HARD_IMPLEMENT_ME(); } - -template <> inline float _log1p(float x) { - float u = (float)1 + x; - if (u == 1) { - return (float)0; - } - return (logf(u) * x) / (u - (float)1); -} - -template <> inline double _log1p(double x) { - double u = (double)1 + x; - if (u == 1) { - return (double)0; - } - return (log(u) * x) / (u - (double)1); -} - -#ifdef CLASP_LONG_FLOAT -template <> inline LongFloat _log1p(LongFloat x) { - LongFloat u = (LongFloat)1 + x; - if (u == 1) { - return (LongFloat)0; +template inline Float _log1p(Float x) { + Float u = Float{1} + x; + if (u == Float{1}) { + return Float{0}; } - return (logl(u) * x) / (u - (LongFloat)1); + return (std::log(u) * x) / (u - Float{1}); } -#endif -bool clasp_zerop(Number_sp num); -bool clasp_plusp(Real_sp num); -bool clasp_minusp(Real_sp num); -bool clasp_evenp(Integer_sp num); -bool clasp_oddp(Integer_sp num); -Number_sp clasp_abs(Number_sp num); -Number_sp clasp_signum(Number_sp num); Number_sp clasp_one_plus(Number_sp num); Number_sp clasp_one_minus(Number_sp num); Number_sp clasp_negate(Number_sp num); -bool clasp_float_nan_p(Float_sp num); -bool clasp_float_infinity_p(Float_sp num); -NumberType clasp_t_of(Number_sp num); Integer_sp clasp_shift_left(Integer_sp num, Fixnum nbits); Integer_sp clasp_shift_right(Integer_sp num, Fixnum nbits); gc::Fixnum clasp_integer_length(Integer_sp x); @@ -212,36 +165,30 @@ void clasp_report_divide_by_zero(Number_sp x); namespace core { -typedef double LongFloat; - -Number_sp contagion_add(Number_sp na, Number_sp nb); -Number_sp contagion_sub(Number_sp na, Number_sp nb); -Number_sp contagion_mul(Number_sp na, Number_sp nb); -Number_sp contagion_div(Number_sp na, Number_sp nb); -int basic_compare(Number_sp na, Number_sp nb); - SMART(Number); class Number_O : public General_O { LISP_ABSTRACT_CLASS(core, ClPkg, Number_O, "number", General_O); public: - static Number_sp create(double val); - static Number_sp create(gc::Fixnum val); - // static Number_sp create(size_t val); -public: + template inline static Float_sp make_float(Float x); + template inline static Complex_sp make_complex(const std::complex x); + virtual Number_sp signum_() const { SUBCLASS_MUST_IMPLEMENT(); }; virtual Number_sp reciprocal_() const { SUBCLASS_MUST_IMPLEMENT(); }; virtual Number_sp abs_() const { SUBCLASS_MUST_IMPLEMENT(); }; virtual bool equal(T_sp obj) const override; virtual bool equalp(T_sp obj) const override; + virtual Real_sp realpart_() const { SUBIMP(); }; + virtual Real_sp imagpart_() const { SUBIMP(); }; + // log(x) (i.e. natural log) virtual Number_sp log1_() const { SUBIMP(); }; // log(x+1) virtual Number_sp log1p_() const; virtual Number_sp sqrt_() const { SUBIMP(); }; - virtual Rational_sp rational_() const = 0; + virtual Rational_sp as_rational_() const = 0; /*! Add one to the number */ virtual Number_sp onePlus_() const { SUBIMP(); }; /*! Subtrace one from the number */ @@ -255,35 +202,196 @@ class Number_O : public General_O { virtual uint as_uint_() const { SUBIMP(); } virtual LongLongInt as_LongLongInt_() const { SUBIMP(); }; - virtual float as_float_() const { SUBIMP(); }; - virtual double as_double_() const { SUBIMP(); } - virtual LongFloat as_long_float_() const { SUBIMP(); }; + virtual short_float_t as_short_float_() const { SUBIMP(); }; + virtual single_float_t as_single_float_() const { SUBIMP(); }; + virtual double_float_t as_double_float_() const { SUBIMP(); } + virtual long_float_t as_long_float_() const { SUBIMP(); }; virtual Number_sp sin_() const { SUBIMP(); }; + virtual Number_sp asin_() const { SUBIMP(); }; virtual Number_sp cos_() const { SUBIMP(); }; + virtual Number_sp acos_() const { SUBIMP(); }; virtual Number_sp tan_() const { SUBIMP(); }; + virtual Number_sp atan_() const { SUBIMP(); }; virtual Number_sp sinh_() const { SUBIMP(); }; virtual Number_sp cosh_() const { SUBIMP(); }; virtual Number_sp tanh_() const { SUBIMP(); }; virtual void sxhash_(HashGenerator& hg) const override { SUBIMP(); }; - Number_O(){}; - virtual ~Number_O(){}; + Number_O() {}; + virtual ~Number_O() {}; + + inline static bool zerop(Number_sp x) { + if (x.fixnump()) + return x.unsafe_fixnum() == 0; +#ifdef CLASP_SHORT_FLOAT + if (x.short_floatp()) + return std::fpclassify(x.unsafe_short_float()) == FP_ZERO; +#endif + if (x.single_floatp()) + return std::fpclassify(x.unsafe_single_float()) == FP_ZERO; + return x->zerop_(); + } + + inline static short_float_t as_short_float(const Number_sp x) { + if (x.fixnump()) + return (short_float_t)x.unsafe_fixnum(); +#ifdef CLASP_SHORT_FLOAT + if (x.short_floatp()) + return (short_float_t)x.unsafe_short_float(); +#endif + if (x.single_floatp()) + return (short_float_t)x.unsafe_single_float(); + return x->as_short_float_(); + } + + inline static single_float_t as_single_float(const Number_sp x) { + if (x.fixnump()) + return (single_float_t)x.unsafe_fixnum(); +#ifdef CLASP_SHORT_FLOAT + if (x.short_floatp()) + return (single_float_t)x.unsafe_short_float(); +#endif + if (x.single_floatp()) + return (single_float_t)x.unsafe_single_float(); + return x->as_single_float_(); + } + + inline static double_float_t as_double_float(const Number_sp x) { + if (x.fixnump()) + return (double_float_t)x.unsafe_fixnum(); +#ifdef CLASP_SHORT_FLOAT + if (x.short_floatp()) + return (double_float_t)x.unsafe_short_float(); +#endif + if (x.single_floatp()) + return (double_float_t)x.unsafe_single_float(); + return x->as_double_float_(); + } + + inline static long_float_t as_long_float(const Number_sp x) { + if (x.fixnump()) + return (long_float_t)x.unsafe_fixnum(); +#ifdef CLASP_SHORT_FLOAT + if (x.short_floatp()) + return (long_float_t)x.unsafe_short_float(); +#endif + if (x.single_floatp()) + return (long_float_t)x.unsafe_single_float(); + return x->as_long_float_(); + } + + inline static Real_sp realpart(const Number_sp x); + inline static Real_sp imagpart(const Number_sp x); + + inline static Number_sp negate(const Number_sp x); + inline static Number_sp signum(const Number_sp num); + + inline static Number_sp abs(const Number_sp x); + inline static Number_sp sqrt(const Number_sp x); + + inline static Number_sp sin(const Number_sp x); + inline static Number_sp asin(const Number_sp x); + inline static Number_sp cos(const Number_sp x); + inline static Number_sp acos(const Number_sp x); + inline static Number_sp tan(const Number_sp x); + static Number_sp atan2(Real_sp y, Real_sp x); + inline static Number_sp atan(Number_sp y); + inline static Number_sp sinh(const Number_sp x); + inline static Number_sp cosh(const Number_sp x); + inline static Number_sp tanh(const Number_sp x); + + static Number_sp add_nn(Number_sp x, Number_sp y); + static Integer_sp add_bb(Bignum_sp x, Bignum_sp y); + static Integer_sp add_bx(Bignum_sp x, Fixnum y); + + static Number_sp sub_nn(Number_sp x, Number_sp y); + static Integer_sp sub_bb(Bignum_sp x, Bignum_sp y); + static Integer_sp sub_xb(Fixnum x, Bignum_sp y); + + static Number_sp mul_nn(Number_sp x, Number_sp y); + static Integer_sp mul_bx(Bignum_sp x, Fixnum y); + static Bignum_sp mul_bb(Bignum_sp x, Bignum_sp y); + + static Number_sp div_nn(Number_sp x, Number_sp y); + + static int compare(const Real_sp na, const Real_sp nb); }; +inline Number_sp operator-(const Number_sp x) { return Number_O::negate(x); } +inline Integer_sp operator-(const Integer_sp x) { return gc::As_unsafe(Number_O::negate(x)); } +inline Real_sp operator-(const Real_sp x) { return gc::As_unsafe(Number_O::negate(x)); } + +inline Number_sp operator+(const Number_sp x, const Number_sp y) { return Number_O::add_nn(x, y); } +inline Integer_sp operator+(const Integer_sp x, const Integer_sp y) { return gc::As_unsafe(Number_O::add_nn(x, y)); } +inline Real_sp operator+(const Real_sp x, const Real_sp y) { return gc::As_unsafe(Number_O::add_nn(x, y)); } + +inline Number_sp operator-(const Number_sp x, const Number_sp y) { return Number_O::sub_nn(x, y); } +inline Integer_sp operator-(const Integer_sp x, const Integer_sp y) { return gc::As_unsafe(Number_O::sub_nn(x, y)); } +inline Real_sp operator-(const Real_sp x, const Real_sp y) { return gc::As_unsafe(Number_O::sub_nn(x, y)); } + +inline Number_sp operator*(const Number_sp x, const Number_sp y) { return Number_O::mul_nn(x, y); } +inline Integer_sp operator*(const Integer_sp x, const Integer_sp y) { return gc::As_unsafe(Number_O::mul_nn(x, y)); } +inline Real_sp operator*(const Real_sp x, const Real_sp y) { return gc::As_unsafe(Number_O::mul_nn(x, y)); } + +inline Number_sp operator/(const Number_sp x, const Number_sp y) { return Number_O::div_nn(x, y); } +inline Rational_sp operator/(const Integer_sp x, const Integer_sp y) { return gc::As_unsafe(Number_O::div_nn(x, y)); } +inline Real_sp operator/(const Real_sp x, const Real_sp y) { return gc::As_unsafe(Number_O::div_nn(x, y)); } + +inline Number_sp operator+=(Number_sp& x, const Number_sp y) { return x = Number_O::add_nn(x, y); }; +inline Integer_sp operator+=(Integer_sp& x, const Integer_sp y) { return x = gc::As_unsafe(Number_O::add_nn(x, y)); }; +inline Real_sp operator+=(Real_sp& x, const Real_sp y) { return x = gc::As_unsafe(Number_O::add_nn(x, y)); }; + +inline Number_sp operator-=(Number_sp& x, const Number_sp y) { return x = Number_O::sub_nn(x, y); }; +inline Integer_sp operator-=(Integer_sp& x, const Integer_sp y) { return x = gc::As_unsafe(Number_O::sub_nn(x, y)); }; +inline Real_sp operator-=(Real_sp& x, const Real_sp y) { return x = gc::As_unsafe(Number_O::sub_nn(x, y)); }; + +inline Number_sp operator*=(Number_sp& x, const Number_sp y) { return x = Number_O::mul_nn(x, y); }; +inline Integer_sp operator*=(Integer_sp& x, const Integer_sp y) { return x = gc::As_unsafe(Number_O::mul_nn(x, y)); }; +inline Real_sp operator*=(Real_sp& x, const Real_sp y) { return x = gc::As_unsafe(Number_O::mul_nn(x, y)); }; + +inline Number_sp operator/=(Number_sp& x, const Number_sp y) { return x = Number_O::div_nn(x, y); }; + SMART(Real); class Real_O : public Number_O { LISP_ABSTRACT_CLASS(core, ClPkg, Real_O, "real", Number_O); public: - virtual double as_double_() const override { SUBIMP(); }; + Real_sp realpart_() const override { return asSmartPtr(); } + Real_sp imagpart_() const override { return clasp_make_fixnum(0); } + + virtual double_float_t as_double_float_() const override { SUBIMP(); }; // functions shared by all Real virtual bool plusp_() const { SUBIMP(); }; virtual bool minusp_() const { SUBIMP(); }; - Real_O(){}; - virtual ~Real_O(){}; + Real_O() {}; + virtual ~Real_O() {}; + + inline static bool plusp(Real_sp x) { + if (x.fixnump()) + return x.unsafe_fixnum() > 0; +#ifdef CLASP_SHORT_FLOAT + if (x.short_floatp()) + return x.unsafe_short_float() > short_float_t{0.0}; +#endif + if (x.single_floatp()) + return x.unsafe_single_float() > single_float_t{0.0}; + return x->plusp_(); + } + + inline static bool minusp(Real_sp x) { + if (x.fixnump()) + return x.unsafe_fixnum() < 0; +#ifdef CLASP_SHORT_FLOAT + if (x.short_floatp()) + return x.unsafe_short_float() < short_float_t{0.0}; +#endif + if (x.single_floatp()) + return x.unsafe_single_float() < single_float_t{0.0}; + return x->minusp_(); + } }; SMART(Rational); @@ -301,14 +409,19 @@ class Rational_O : public Real_O { virtual Number_sp exp_() const override; virtual Number_sp sin_() const override; + virtual Number_sp asin_() const override; virtual Number_sp cos_() const override; + virtual Number_sp acos_() const override; virtual Number_sp tan_() const override; + virtual Number_sp atan_() const override; virtual Number_sp sinh_() const override; virtual Number_sp cosh_() const override; virtual Number_sp tanh_() const override; - Rational_O(){}; - virtual ~Rational_O(){}; + Rational_O() {}; + virtual ~Rational_O() {}; + + inline static Rational_sp coerce(const Real_sp x); }; SMART(Integer); @@ -321,7 +434,8 @@ class Integer_O : public Rational_O { static Integer_sp create(std::signed_integral auto v); static Integer_sp create(std::unsigned_integral auto v); - static Integer_sp create(std::floating_point auto v); + + template static Integer_sp create(Float v); static Integer_sp create(int8_t v); static Integer_sp create(uint8_t v); @@ -362,8 +476,20 @@ class Integer_O : public Rational_O { virtual Integer_sp shift_right(gc::Fixnum nbits) const { SUBIMP(); }; virtual void __write__(T_sp strm) const override; - Integer_O(){}; - virtual ~Integer_O(){}; + Integer_O() {}; + virtual ~Integer_O() {}; + + inline static bool evenp(const Integer_sp x) { + if (x.fixnump()) + return (x.unsafe_fixnum() % 2) == 0; + return x->evenp_(); + } + + inline static bool oddp(const Integer_sp x) { + if (x.fixnump()) + return (x.unsafe_fixnum() % 2) != 0; + return x->oddp_(); + } }; }; // namespace core @@ -389,66 +515,73 @@ class Float_O : public Real_O { virtual bool isnan_() const { SUBIMP(); }; virtual bool isinf_() const { SUBIMP(); }; + virtual int fpclassify_() const { SUBIMP(); }; - Float_O(){}; - virtual ~Float_O(){}; -}; - -SMART(ShortFloat); -class ShortFloat_O : public Float_O { - LISP_ABSTRACT_CLASS(core, ClPkg, ShortFloat_O, "ShortFloat", Float_O); + Float_O() {}; + virtual ~Float_O() {}; -private: - float _Value; + inline static bool isnan(Float_sp x) { +#ifdef CLASP_SHORT_FLOAT + if (x.short_floatp()) + return std::isnan(x.unsafe_short_float()); +#endif + if (x.single_floatp()) + return std::isnan(x.unsafe_single_float()); + return x->isnan_(); + } -public: - static ShortFloat_sp create(float nm) { - auto sf = gctools::GC::allocate_with_default_constructor(); - sf->_Value = nm; - return sf; - }; + inline static bool isinf(Float_sp x) { +#ifdef CLASP_SHORT_FLOAT + if (x.short_floatp()) + return std::isinf(x.unsafe_short_float()); +#endif + if (x.single_floatp()) + return std::isinf(x.unsafe_single_float()); + return x->isinf_(); + } -public: - float get() const { return this->_Value; }; - void sxhash_(HashGenerator& hg) const override; - // virtual Number_sp copy() const; - Number_sp signum_() const override; - string __repr__() const override; - Number_sp abs_() const override; - bool isnan_() const override { return std::isnan(this->_Value); }; // NaN is supposed to be the only value that != itself! - bool isinf_() const override { return std::isinf(this->_Value); }; + inline static int fpclassify(Float_sp x) { +#ifdef CLASP_SHORT_FLOAT + if (x.short_floatp()) + return std::fpclassify(x.unsafe_short_float()); +#endif + if (x.single_floatp()) + return std::fpclassify(x.unsafe_single_float()); + return x->fpclassify_(); + } +}; -public: - // virtual bool eqn(T_sp obj) const; - virtual bool eql_(T_sp obj) const override; - virtual Number_sp reciprocal_() const override; +class SingleFloat_dummy_O : public Float_O { + LISP_ABSTRACT_CLASS(core, ClPkg, SingleFloat_dummy_O, "SingleFloat", Float_O); - // math routines shared by all numbers - virtual bool zerop_() const override { return this->_Value == 0.0; }; - virtual Number_sp negate_() const override { return ShortFloat_O::create(-this->_Value); }; + inline static SingleFloat_sp create(float x) { return gc::make_tagged_single_float(x); }; - virtual Number_sp onePlus_() const override { return ShortFloat_O::create(this->_Value + 1.0); }; - virtual Number_sp oneMinus_() const override { return ShortFloat_O::create(this->_Value - 1.0); }; + static SingleFloat_sp coerce(Number_sp x); +}; - // shared by real - virtual bool plusp_() const override { return this->_Value > 0.0; }; - virtual bool minusp_() const override { return this->_Value < 0.0; }; +#ifdef CLASP_SHORT_FLOAT +template <> inline Float_sp Number_O::make_float(short_float_t x) { return ShortFloat_O::create(x); } +#endif - virtual float as_float_() const override; - virtual double as_double_() const override; - virtual LongFloat as_long_float_() const override; +class ShortFloat_O : public Float_O { + LISP_ABSTRACT_CLASS(core, ClPkg, ShortFloat_O, "ShortFloat", Float_O); - Integer_sp castToInteger() const override; +#ifdef CLASP_SHORT_FLOAT + inline static ShortFloat_sp create(float x) { return gc::make_tagged_short_float(x); }; - DEFAULT_CTOR_DTOR(ShortFloat_O); -}; + static ShortFloat_sp coerce(Number_sp x); +#else + inline static SingleFloat_sp create(float x) { return gc::make_tagged_single_float(x); }; -class SingleFloat_dummy_O : public Float_O { - LISP_ABSTRACT_CLASS(core, ClPkg, SingleFloat_dummy_O, "SingleFloat", Float_O); + inline static SingleFloat_sp coerce(Number_sp x) { return SingleFloat_dummy_O::coerce(x); } +#endif }; inline SingleFloat_sp make_single_float(float x) { return gc::make_tagged_single_float(x); }; inline float unbox_single_float(SingleFloat_sp x) { return x.unsafe_single_float(); }; + +template <> inline Float_sp Number_O::make_float(single_float_t x) { return SingleFloat_dummy_O::create(x); } + }; // namespace core template <> struct gctools::GCInfo { @@ -462,7 +595,6 @@ SMART(DoubleFloat); class DoubleFloat_O : public Float_O { LISP_CLASS(core, ClPkg, DoubleFloat_O, "double-float", Float_O); -public: private: double _Value; @@ -473,27 +605,27 @@ class DoubleFloat_O : public Float_O { return v; }; -public: - static Rational_sp rational(double val); + static DoubleFloat_sp coerce(Number_sp x); -public: void sxhash_(HashGenerator& hg) const override; // virtual Number_sp copy() const; string __repr__() const override; void set(double val) { this->_Value = val; }; double get() const { return this->_Value; }; + + Real_sp imagpart_() const override; + Number_sp signum_() const override; - Number_sp abs_() const override { - return DoubleFloat_O::create(fabs(this->_Value)); - }; + Number_sp abs_() const override { return DoubleFloat_O::create(std::abs(this->_Value)); }; bool isnan_() const override { return std::isnan(this->_Value); }; // NaN is supposed to be the only value that != itself!!!! bool isinf_() const override { return std::isinf(this->_Value); }; + int fpclassify_() const override { return std::fpclassify(_Value); } public: virtual bool eql_(T_sp obj) const override; // math routines shared by all numbers - bool zerop_() const override { return this->_Value == 0.0; }; + bool zerop_() const override { return std::fpclassify(this->_Value) == FP_ZERO; }; virtual Number_sp negate_() const override { return DoubleFloat_O::create(-this->_Value); }; // Shared by real @@ -509,45 +641,129 @@ class DoubleFloat_O : public Float_O { virtual Number_sp log1_() const override; virtual Number_sp log1p_() const override; - virtual float as_float_() const override; - virtual double as_double_() const override; - virtual LongFloat as_long_float_() const override; + virtual short_float_t as_short_float_() const override; + virtual single_float_t as_single_float_() const override; + virtual double_float_t as_double_float_() const override; + virtual long_float_t as_long_float_() const override; Integer_sp castToInteger() const override; virtual Number_sp exp_() const override; virtual Number_sp sin_() const override; + virtual Number_sp asin_() const override; virtual Number_sp cos_() const override; + virtual Number_sp acos_() const override; virtual Number_sp tan_() const override; + virtual Number_sp atan_() const override; virtual Number_sp sinh_() const override; virtual Number_sp cosh_() const override; virtual Number_sp tanh_() const override; - virtual Rational_sp rational_() const final { return DoubleFloat_O::rational(this->_Value); }; - DoubleFloat_O() : _Value(0.0){}; - virtual ~DoubleFloat_O(){}; + virtual Rational_sp as_rational_() const override; + DoubleFloat_O() : _Value(0.0) {}; + virtual ~DoubleFloat_O() {}; }; + +template <> inline Float_sp Number_O::make_float(double_float_t x) { return DoubleFloat_O::create(x); } + }; // namespace core +#ifdef CLASP_LONG_FLOAT +template <> struct gctools::GCInfo { + static bool constexpr NeedsInitialization = false; + static bool constexpr NeedsFinalization = false; + static GCInfo_policy constexpr Policy = atomic; +}; +#endif + namespace core { SMART(LongFloat); class LongFloat_O : public Float_O { - LISP_ABSTRACT_CLASS(core, ClPkg, LongFloat_O, "LongFloat", Float_O); +#ifdef CLASP_LONG_FLOAT + LISP_CLASS(core, ClPkg, LongFloat_O, "long-float", Float_O); +#else + LISP_ABSTRACT_CLASS(core, ClPkg, LongFloat_O, "long-float", Float_O); +#endif -public: private: - // LongFloat _Value; -public: - static DoubleFloat_sp create(LongFloat nm) { return DoubleFloat_O::create(nm); }; + long_float_t _Value; public: - // virtual Rational_sp rational_() const final { return DoubleFloat_O::rational(this->_Value); }; +#ifdef CLASP_LONG_FLOAT + static LongFloat_sp create(long_float_t nm) { + auto v = gctools::GC::allocate_with_default_constructor(); + v->set(nm); + return v; + }; + + static LongFloat_sp coerce(Number_sp x); + + void sxhash_(HashGenerator& hg) const override; + string __repr__() const override; + void set(long_float_t val) { this->_Value = val; }; + long_float_t get() const { return this->_Value; }; + + Real_sp imagpart_() const override; + + Number_sp signum_() const override; + Number_sp abs_() const override { return LongFloat_O::create(std::abs(this->_Value)); }; + bool isnan_() const override { return std::isnan(this->_Value); }; // NaN is supposed to be the only value that != itself!!!! + bool isinf_() const override { return std::isinf(this->_Value); }; + int fpclassify_() const override { return std::fpclassify(_Value); } + + virtual bool eql_(T_sp obj) const override; + + // math routines shared by all numbers + bool zerop_() const override { return std::fpclassify(this->_Value) == FP_ZERO; }; + virtual Number_sp negate_() const override { return LongFloat_O::create(-this->_Value); }; + + // Shared by real + bool plusp_() const override { return this->_Value > long_float_t{0.0}; }; + bool minusp_() const override { return this->_Value < long_float_t{0.0}; }; + + virtual Number_sp reciprocal_() const override; + virtual Number_sp sqrt_() const override; + + virtual Number_sp onePlus_() const override { return create(this->_Value + long_float_t{1.0}); }; + virtual Number_sp oneMinus_() const override { return create(this->_Value - long_float_t{1.0}); }; + + virtual Number_sp log1_() const override; + virtual Number_sp log1p_() const override; + + virtual short_float_t as_short_float_() const override; + virtual single_float_t as_single_float_() const override; + virtual double_float_t as_double_float_() const override; + virtual long_float_t as_long_float_() const override; + + Integer_sp castToInteger() const override; + + virtual Number_sp exp_() const override; + + virtual Number_sp sin_() const override; + virtual Number_sp asin_() const override; + virtual Number_sp cos_() const override; + virtual Number_sp acos_() const override; + virtual Number_sp tan_() const override; + virtual Number_sp atan_() const override; + virtual Number_sp sinh_() const override; + virtual Number_sp cosh_() const override; + virtual Number_sp tanh_() const override; + virtual Rational_sp as_rational_() const override; + LongFloat_O() : _Value(long_float_t{0.0}) {}; + virtual ~LongFloat_O() {}; +#else + inline static DoubleFloat_sp create(long_float_t nm) { return DoubleFloat_O::create(nm); } + + inline static DoubleFloat_sp coerce(Number_sp x) { return DoubleFloat_O::coerce(x); } DEFAULT_CTOR_DTOR(LongFloat_O); +#endif }; -}; // namespace core -namespace core { +#ifdef CLASP_LONG_FLOAT +template <> inline Float_sp Number_O::make_float(long_float_t x) { return LongFloat_O::create(x); } +#endif + SMART(Complex); class Complex_O : public Number_O { LISP_CLASS(core, ClPkg, Complex_O, "complex", Number_O); @@ -575,16 +791,20 @@ class Complex_O : public Number_O { void sxhash_(HashGenerator& hg) const override; // virtual Number_sp copy() const; string __repr__() const override; + + Real_sp realpart_() const override { return _real; } + Real_sp imagpart_() const override { return _imaginary; } + Number_sp signum_() const override; Number_sp abs_() const override; - Rational_sp rational_() const override { TYPE_ERROR(this->asSmartPtr(), cl::_sym_Real_O); }; + Rational_sp as_rational_() const override { TYPE_ERROR(this->asSmartPtr(), cl::_sym_Real_O); }; public: // virtual bool eqn(T_sp obj) const; virtual bool eql_(T_sp obj) const override; // math routines shared by all numbers - bool zerop_() const override { return (clasp_zerop(this->_real) && clasp_zerop(this->_imaginary)); }; + bool zerop_() const override { return (zerop(this->_real) && zerop(this->_imaginary)); }; virtual Number_sp negate_() const override { return Complex_O::create(gc::As(clasp_negate(this->_real)), gc::As(clasp_negate(this->_imaginary))); }; @@ -600,8 +820,11 @@ class Complex_O : public Number_O { virtual Number_sp exp_() const override; virtual Number_sp sin_() const override; + virtual Number_sp asin_() const override; virtual Number_sp cos_() const override; + virtual Number_sp acos_() const override; virtual Number_sp tan_() const override; + virtual Number_sp atan_() const override; virtual Number_sp sinh_() const override; virtual Number_sp cosh_() const override; virtual Number_sp tanh_() const override; @@ -611,11 +834,15 @@ class Complex_O : public Number_O { virtual void __write__(T_sp strm) const override; - Complex_O(Real_sp r, Real_sp i) : _real(r), _imaginary(i){}; - Complex_O() : _real(clasp_make_single_float(0.0)), _imaginary(clasp_make_single_float(0.0)){}; - virtual ~Complex_O(){}; + Complex_O(Real_sp r, Real_sp i) : _real(r), _imaginary(i) {}; + Complex_O() : _real(clasp_make_single_float(0.0)), _imaginary(clasp_make_single_float(0.0)) {}; + virtual ~Complex_O() {}; }; +template inline Complex_sp Number_O::make_complex(const std::complex x) { + return Complex_O::create(make_float(x.real()), make_float(x.imag())); +} + SMART(Ratio); class Ratio_O : public Rational_O { LISP_CLASS(core, ClPkg, Ratio_O, "ratio", Rational_O); @@ -646,7 +873,7 @@ class Ratio_O : public Rational_O { void setf_numerator_denominator(core::Integer_sp num, core::Integer_sp denom); public: - virtual bool zerop_() const override { return clasp_zerop(this->_numerator); }; + virtual bool zerop_() const override { return zerop(this->_numerator); }; virtual Number_sp negate_() const override { return Ratio_O::create_primitive(gc::As(clasp_negate(this->_numerator)), gc::As(this->_denominator)); }; @@ -660,44 +887,35 @@ class Ratio_O : public Rational_O { Number_sp abs_() const override; Number_sp sqrt_() const override; Number_sp reciprocal_() const override; - Rational_sp rational_() const final { return this->asSmartPtr(); }; + Rational_sp as_rational_() const override { return this->asSmartPtr(); }; bool isnan_() const; public: virtual bool eql_(T_sp obj) const override; - Number_sp onePlus_() const override { - return create(gc::As(contagion_add(this->_numerator, this->_denominator)), this->_denominator); - }; + Number_sp onePlus_() const override { return create(_numerator + _denominator, _denominator); }; + Number_sp oneMinus_() const override { - return create(gc::As(contagion_sub(this->_numerator, this->_denominator)), this->_denominator); + return create(gc::As(this->_numerator - this->_denominator), this->_denominator); }; - virtual float as_float_() const override; - virtual double as_double_() const override; - virtual LongFloat as_long_float_() const override; + virtual short_float_t as_short_float_() const override; + virtual single_float_t as_single_float_() const override; + virtual double_float_t as_double_float_() const override; + virtual long_float_t as_long_float_() const override; // functions shared by all Real - bool plusp_() const override { return clasp_plusp(this->_numerator); } + bool plusp_() const override { return plusp(this->_numerator); } - bool minusp_() const override { return clasp_minusp(this->_numerator); } + bool minusp_() const override { return minusp(this->_numerator); } virtual void __write__(T_sp strm) const override; - Ratio_O() : _numerator(clasp_make_fixnum(0)), _denominator(clasp_make_fixnum(1)){}; - virtual ~Ratio_O(){}; + Ratio_O() : _numerator(clasp_make_fixnum(0)), _denominator(clasp_make_fixnum(1)) {}; + virtual ~Ratio_O() {}; }; -inline Number_sp clasp_plus(Number_sp na, Number_sp nb) { return contagion_add(na, nb); }; -inline Number_sp clasp_minus(Number_sp na, Number_sp nb) { return contagion_sub(na, nb); }; -inline Number_sp clasp_times(Number_sp na, Number_sp nb) { return contagion_mul(na, nb); }; -inline Number_sp clasp_divide(Number_sp na, Number_sp nb) { return contagion_div(na, nb); }; - -inline int clasp_number_compare(Number_sp x, Number_sp y) { return basic_compare(x, y); }; - -Number_sp clasp_atan2(Number_sp x, Number_sp y); - inline Number_sp float_sqrt(float f) { if (f < 0.0) { return Complex_O::create(clasp_make_single_float(0.0), clasp_make_single_float(sqrtf(-f))); @@ -712,7 +930,18 @@ inline Number_sp clasp_log1(Number_sp x) { if (f < 0) return clasp_log1_complex_inner(x, clasp_make_fixnum(0)); return clasp_make_single_float(logf(f)); - } else if (x.single_floatp()) { + } +#ifdef CLASP_SHORT_FLOAT + if (x.short_floatp()) { + short_float_t f = x.unsafe_short_float(); + if (std::isnan(f)) + return x; + if (f < 0) + return clasp_log1_complex_inner(x, clasp_make_fixnum(0)); + return ShortFloat_O::create(logf(f)); + } +#endif + if (x.single_floatp()) { float f = x.unsafe_single_float(); if (std::isnan(f)) return x; @@ -729,7 +958,18 @@ inline Number_sp clasp_log1p(Number_sp x) { if (f < -1) return clasp_log1_complex_inner(clasp_one_plus(x), clasp_make_fixnum(0)); return clasp_make_single_float(_log1p(f)); - } else if (x.single_floatp()) { + } +#ifdef CLASP_SHORT_FLOAT + if (x.short_floatp()) { + short_float_t f = x.unsafe_short_float(); + if (std::isnan(f)) + return x; + if (f < -1) + return clasp_log1_complex_inner(clasp_one_plus(x), clasp_make_fixnum(0)); + return ShortFloat_O::create(_log1p(f)); + } +#endif + if (x.single_floatp()) { float f = x.unsafe_single_float(); if (std::isnan(f)) return x; @@ -740,32 +980,41 @@ inline Number_sp clasp_log1p(Number_sp x) { return x->log1p_(); }; -Number_sp cl__expt(Number_sp x, Number_sp y); -Real_sp cl__mod(Real_sp, Real_sp); +template inline Rational_sp float_to_rational(Float f) { + auto q = float_convert::float_to_quadruple(f); -Integer_sp clasp_ash(Integer_sp x, int bits); - -inline gctools::Fixnum clasp_safe_fixnum(Number_sp x) { return gc::As(x).unsafe_fixnum(); } + Number_sp n = Integer_O::create(q.significand); -#if 0 - inline gctools::Fixnum clasp_fixnum(Number_sp x) { - return unbox_fixnum(Fixnum_sp(x)); + if (q.exponent < 0) { + n /= clasp_ash(clasp_make_fixnum(1), -q.exponent); + } else if (q.exponent > 0) { + n = clasp_ash(n.as_unsafe(), q.exponent); } - inline float clasp_single_float(Number_sp x) { - if (x.single_floatp()) { - return unbox_single_float(x); - } - } + if (q.sign < 0) + return clasp_negate(n).as_unsafe(); - inline double clasp_double_float(Number_sp x) { - return gc::As(x)->get(); - } -#endif + return n.as_unsafe(); +} -#ifdef CLASP_LONG_FLOAT -inline LongFloat clasp_long_float(Number_sp x) { return x.as()->get(); } +inline Rational_sp Rational_O::coerce(const Real_sp x) { + if (x.fixnump()) + return x.as_unsafe(); +#ifdef CLASP_SHORT_FLOAT + if (x.short_floatp()) + return float_to_rational(x.unsafe_short_float()); #endif + if (x.single_floatp()) + return float_to_rational(x.unsafe_single_float()); + return gc::As_unsafe(x)->as_rational_(); +} + +Number_sp cl__expt(Number_sp x, Number_sp y); +Real_sp cl__mod(Real_sp, Real_sp); + +Integer_sp clasp_ash(Integer_sp x, int bits); + +inline gctools::Fixnum clasp_safe_fixnum(Number_sp x) { return gc::As(x).unsafe_fixnum(); } Number_sp clasp_make_complex(Real_sp r, Real_sp i); @@ -775,16 +1024,16 @@ inline Integer_sp _clasp_float_to_integer(float d) { return Integer_O::create(d) inline Integer_sp _clasp_double_to_integer(double d) { return Integer_O::create(d); } -inline Integer_sp _clasp_long_float_to_integer(LongFloat d) { return Integer_O::create(d); } +inline Integer_sp _clasp_long_float_to_integer(long_float_t d) { return Integer_O::create(d); } -inline Integer_sp _clasp_long_double_to_integer(LongFloat d) { return Integer_O::create(d); } +inline Integer_sp _clasp_long_double_to_integer(long_float_t d) { return Integer_O::create(d); } inline SingleFloat_sp clasp_make_single_float(float d) { return gc::make_tagged_single_float(d); } inline DoubleFloat_sp clasp_make_double_float(double d) { return DoubleFloat_O::create(d); } #ifdef CLASP_LONG_FLOAT -inline LongFloat_sp clasp_make_long_float(LongFloat d) { return LongFloat_O::create(d); } +inline LongFloat_sp clasp_make_long_float(long_float_t d) { return LongFloat_O::create(d); } #endif #define CLASP_REAL_TYPE_P(y) (gc::IsA(y)) @@ -806,111 +1055,16 @@ Real_mv clasp_round2(Real_sp x, Real_sp y); Real_sp clasp_max2(Real_sp x, Real_sp y); Real_sp clasp_min2(Real_sp x, Real_sp y); -#define clasp_lowereq(x, y) (clasp_number_compare((x), (y)) <= 0) -#define clasp_greatereq(x, y) (clasp_number_compare((x), (y)) >= 0) -#define clasp_lower(x, y) (clasp_number_compare((x), (y)) < 0) -#define clasp_greater(x, y) (clasp_number_compare((x), (y)) > 0) - -}; // namespace core - -template struct fmt::formatter : fmt::formatter> { - template - auto format(const core::NumberType& o, FormatContext& ctx) const -> typename FormatContext::iterator { - fmt::basic_string_view name = "unknown"; - switch (o) { - case core::number_Fixnum: - name = "Fixnum"; - break; - case core::number_Bignum: - name = "Bignum"; - break; - case core::number_Ratio: - name = "Ratio"; - break; - case core::number_ShortFloat: - name = "ShortFloat"; - break; - case core::number_SingleFloat: - name = "SingleFloat"; - break; - case core::number_DoubleFloat: - name = "DoubleFloat"; - break; - case core::number_LongFloat: - name = "LongFloat"; - break; - case core::number_Complex: - name = "Complex"; - break; - case core::number_NUM: - name = "NUM"; - break; - } - return fmt::formatter>::format(name, ctx); - } -}; - -namespace core { - -CL_PKG_NAME(ClPkg, plusp); -CL_DEFUN inline bool clasp_plusp(Real_sp num) { - if (num.fixnump()) { - return num.unsafe_fixnum() > 0; - } else if (num.single_floatp()) { - return num.unsafe_single_float() > 0.0; - } - return num->plusp_(); -} - -CL_PKG_NAME(ClPkg, minusp); -CL_DEFUN inline bool clasp_minusp(Real_sp num) { - if (num.fixnump()) { - return num.unsafe_fixnum() < 0; - } else if (num.single_floatp()) { - return num.unsafe_single_float() < 0.0; - } - return num->minusp_(); -} - -CL_PKG_NAME(ClPkg, evenp); -CL_DEFUN inline bool clasp_evenp(Integer_sp num) { - if (num.fixnump()) { - return (num.unsafe_fixnum() % 2) == 0; - } - return num->evenp_(); -} - -CL_PKG_NAME(ClPkg, oddp); -DOCGROUP(clasp) -CL_DEFUN inline bool clasp_oddp(Integer_sp num) { - // for negative numbers num % 2 == 1 does not work, since -1 is returned - if (num.fixnump()) { - return (num.unsafe_fixnum() % 2) != 0; - } - // now num must be a bignum, works fine - return num->oddp_(); -} +#define clasp_lowereq(x, y) (Number_O::compare((x), (y)) <= 0) +#define clasp_greatereq(x, y) (Number_O::compare((x), (y)) >= 0) +#define clasp_lower(x, y) (Number_O::compare((x), (y)) < 0) +#define clasp_greater(x, y) (Number_O::compare((x), (y)) > 0) -CL_PKG_NAME(ClPkg, abs); -DOCGROUP(clasp) -CL_DEFUN inline Number_sp clasp_abs(Number_sp num) { - if (num.fixnump()) { - gc::Fixnum fixnum = num.unsafe_fixnum(); - if (fixnum == MOST_NEGATIVE_FIXNUM) { - // will overflow to a bignum - fixnum = (MOST_POSITIVE_FIXNUM + 1); - return Integer_O::create(fixnum); - } else - return immediate_fixnum(std::abs(fixnum)); - } else if (num.single_floatp()) { - return immediate_single_float(std::fabs(num.unsafe_single_float())); - } - return num->abs_(); +template inline Float _signum(Float x) { + return (std::fpclassify(x) == FP_ZERO) ? x : std::copysign(Float{1}, x); } -CL_PKG_NAME(ClPkg, signum); -DOCGROUP(clasp) -CL_DEFUN inline Number_sp clasp_signum(Number_sp num) { +inline Number_sp Number_O::signum(const Number_sp num) { if (num.fixnump()) { Fixnum fn = num.unsafe_fixnum(); if (fn == 0) @@ -918,14 +1072,13 @@ CL_DEFUN inline Number_sp clasp_signum(Number_sp num) { if (fn > 0) return immediate_fixnum(1); return immediate_fixnum(-1); - } else if (num.single_floatp()) { - float fl = num.unsafe_single_float(); - if (fl == 0.0) - return immediate_single_float(0.0); - if (fl < 0.0) - return immediate_single_float(-1.0); - return immediate_single_float(1.0); } +#ifdef CLASP_SHORT_FLOAT + if (num.short_floatp()) + return ShortFloat_O::create(_signum(num.unsafe_short_float())); +#endif + if (num.single_floatp()) + return SingleFloat_dummy_O::create(_signum(num.unsafe_single_float())); return num->signum_(); } @@ -938,11 +1091,13 @@ inline Number_sp clasp_one_plus(Number_sp num) { return Integer_O::create(fixnum); } else return immediate_fixnum(fixnum + 1); - } else if (num.single_floatp()) { - float fl = num.unsafe_single_float(); - fl += 1.0; - return immediate_single_float(fl); } +#ifdef CLASP_SHORT_FLOAT + if (num.short_floatp()) + return ShortFloat_O::create(num.unsafe_short_float() + short_float_t{1}); +#endif + if (num.single_floatp()) + return SingleFloat_dummy_O::create(num.unsafe_single_float() + single_float_t{1}); return num->onePlus_(); } @@ -955,24 +1110,16 @@ inline Number_sp clasp_one_minus(Number_sp num) { return Integer_O::create(fixnum); } else return immediate_fixnum(fixnum - 1); - } else if (num.single_floatp()) { - float fl = num.unsafe_single_float(); - fl -= 1.0; - return immediate_single_float(fl); } +#ifdef CLASP_SHORT_FLOAT + if (num.short_floatp()) + return ShortFloat_O::create(num.unsafe_short_float() - short_float_t{1}); +#endif + if (num.single_floatp()) + return SingleFloat_dummy_O::create(num.unsafe_single_float() - single_float_t{1}); return num->oneMinus_(); } -inline bool clasp_zerop(Number_sp num) { - if (num.fixnump()) { - return num.unsafe_fixnum() == 0; - } else if (num.single_floatp()) { - float fl = num.unsafe_single_float(); - return fl == 0.0; - } - return num->zerop_(); -} - CL_LISPIFY_NAME(negate); DOCGROUP(clasp) CL_DEFUN inline Number_sp clasp_negate(Number_sp num) { @@ -984,34 +1131,14 @@ CL_DEFUN inline Number_sp clasp_negate(Number_sp num) { return Integer_O::create(fixnum); } else return immediate_fixnum(-fixnum); - } else if (num.single_floatp()) { - float fl = num.unsafe_single_float(); - fl = -fl; - return immediate_single_float(fl); } - return num->negate_(); -} - -inline NumberType clasp_t_of(Number_sp n) { - if (n.fixnump()) - return number_Fixnum; - else if (n.single_floatp()) - return number_SingleFloat; - else if (gc::IsA(n)) - return number_Bignum; - else if (gc::IsA(n)) - return number_Ratio; - else if (gc::IsA(n)) - return number_ShortFloat; - else if (gc::IsA(n)) - return number_DoubleFloat; -#ifdef CLASP_LONG_FLOAT - else if (gc::IsA(n)) - return number_LongFloat; +#ifdef CLASP_SHORT_FLOAT + if (num.short_floatp()) + return ShortFloat_O::create(-num.unsafe_short_float()); #endif - else if (gc::IsA(n)) - return number_Complex; - UNREACHABLE(); + if (num.single_floatp()) + return SingleFloat_dummy_O::create(-num.unsafe_single_float()); + return num->negate_(); } inline Integer_sp clasp_shift_left(Integer_sp n, Fixnum bits) { @@ -1042,6 +1169,7 @@ inline Integer_sp clasp_shift_left(Integer_sp n, Fixnum bits) { } else return n->shift_left(bits); } + inline Integer_sp clasp_shift_right(Integer_sp n, Fixnum nbits) { if (n.fixnump()) { Fixnum y = n.unsafe_fixnum(); @@ -1091,22 +1219,11 @@ ssize_t clasp_to_ssize_t(core::T_sp); mpz_class clasp_to_mpz(core::T_sp); float clasp_to_float(core::Number_sp); -LongFloat clasp_to_long_float(core::Number_sp); -LongFloat clasp_to_long_double(core::Number_sp); +double clasp_to_double(core::Number_sp); +long_float_t clasp_to_long_float(core::Number_sp); // END OF CLASP_TO_... FUNCTIONS -inline Number_sp clasp_sqrt(Number_sp z) { - if (z.fixnump()) { - float f = z.unsafe_fixnum(); - return float_sqrt(f); - } else if (z.single_floatp()) { - float f = z.unsafe_single_float(); - return float_sqrt(f); - } - return z->sqrt_(); -} - CL_LISPIFY_NAME(reciprocal); DOCGROUP(clasp) CL_DEFUN inline Number_sp clasp_reciprocal(Number_sp x) { @@ -1126,96 +1243,247 @@ CL_DEFUN inline Number_sp clasp_reciprocal(Number_sp x) { else return Ratio_O::create_primitive(clasp_make_fixnum(-1), clasp_make_fixnum(-fx)); } - } else if (x.single_floatp()) { - float f = x.unsafe_single_float(); - return clasp_make_single_float(1.0 / f); } +#ifdef CLASP_SHORT_FLOAT + if (x.short_floatp()) + return ShortFloat_O::create(short_float_t{1.0} / x.unsafe_short_float()); +#endif + if (x.single_floatp()) + return clasp_make_single_float(single_float_t{1.0} / x.unsafe_single_float()); return x->reciprocal_(); } inline Number_sp clasp_exp(Number_sp x) { - if (x.fixnump()) { - float f = x.unsafe_fixnum(); - return clasp_make_single_float(expf(f)); - } else if (x.single_floatp()) { - float f = x.unsafe_single_float(); - return clasp_make_single_float(expf(f)); - } + if (x.fixnump()) + return clasp_make_single_float(std::exp((single_float_t)x.unsafe_fixnum())); +#ifdef CLASP_SHORT_FLOAT + if (x.short_floatp()) + return ShortFloat_O::create(std::exp(x.unsafe_short_float())); +#endif + if (x.single_floatp()) + return clasp_make_single_float(std::exp(x.unsafe_single_float())); return x->exp_(); } -inline Number_sp clasp_sin(Number_sp x) { +inline Number_sp clasp_conjugate(Number_sp x) { + if (gc::IsA(x)) + return gc::As_unsafe(x)->conjugate(); + else + return x; +} + +inline Number_sp Number_O::abs(Number_sp x) { if (x.fixnump()) { - float f = x.unsafe_fixnum(); - return clasp_make_single_float(sinf(f)); - } else if (x.single_floatp()) - return clasp_make_single_float(sinf(x.unsafe_single_float())); + gc::Fixnum fixnum = x.unsafe_fixnum(); + if (fixnum == MOST_NEGATIVE_FIXNUM) + return Integer_O::create(MOST_POSITIVE_FIXNUM + 1); + return clasp_make_fixnum(std::abs(fixnum)); + } +#ifdef CLASP_SHORT_FLOAT + if (x.short_floatp()) + return make_float(std::abs(x.unsafe_short_float())); +#endif + if (x.single_floatp()) + return make_float(std::abs(x.unsafe_single_float())); + return x->abs_(); +} + +inline Number_sp Number_O::sqrt(const Number_sp x) { + if (x.fixnump()) + return float_sqrt((single_float_t)x.unsafe_fixnum()); +#ifdef CLASP_SHORT_FLOAT + if (x.short_floatp()) + return make_float(std::sqrt(x.unsafe_short_float())); +#endif + if (x.single_floatp()) + return float_sqrt(x.unsafe_single_float()); + return x->sqrt_(); +} + +inline Number_sp Number_O::sin(const Number_sp x) { + if (x.fixnump()) + return SingleFloat_dummy_O::create(std::sin((single_float_t)x.unsafe_fixnum())); +#ifdef CLASP_SHORT_FLOAT + if (x.short_floatp()) + return make_float(std::sin(x.unsafe_short_float())); +#endif + if (x.single_floatp()) + return SingleFloat_dummy_O::create(std::sin(x.unsafe_single_float())); return x->sin_(); } -inline Number_sp clasp_cos(Number_sp x) { - if (x.fixnump()) { - float f = x.unsafe_fixnum(); - return clasp_make_single_float(cosf(f)); - } else if (x.single_floatp()) - return clasp_make_single_float(cosf(x.unsafe_single_float())); + +template Number_sp _asin(Float z) { + if (z >= Float{-1} && z <= Float{1}) + return Number_O::make_float((Float)std::asin((Float2)z)); + + return Complex_O::create(Number_O::make_float(std::copysign(std::numbers::pi_v * Float{0.5}, z)), + Number_O::make_float(std::asinh(std::copysign(std::sqrt(z * z - Float{1.0}), -z)))); +} + +inline Number_sp Number_O::asin(const Number_sp x) { + if (x.fixnump()) +#ifdef _TARGET_OS_DARWIN + return _asin(x.unsafe_fixnum()); +#else + return _asin((single_float_t)x.unsafe_fixnum()); +#endif +#ifdef CLASP_SHORT_FLOAT + if (x.short_floatp()) + return _asin(x.unsafe_short_float()); +#endif + if (x.single_floatp()) +#ifdef _TARGET_OS_DARWIN + return _asin(x.unsafe_single_float()); +#else + return _asin(x.unsafe_single_float()); +#endif + return x->asin_(); +} + +inline Number_sp Number_O::cos(Number_sp x) { + if (x.fixnump()) + return SingleFloat_dummy_O::create(std::cos((single_float_t)x.unsafe_fixnum())); +#ifdef CLASP_SHORT_FLOAT + if (x.short_floatp()) + return ShortFloat_O::create(std::cos(x.unsafe_short_float())); +#endif + if (x.single_floatp()) + return SingleFloat_dummy_O::create(std::cos(x.unsafe_single_float())); return x->cos_(); } -inline Number_sp clasp_tan(Number_sp x) { - if (x.fixnump()) { - float f = x.unsafe_fixnum(); - return clasp_make_single_float(tanf(f)); - } else if (x.single_floatp()) - return clasp_make_single_float(tanf(x.unsafe_single_float())); + +template Number_sp _acos(Float z) { + if (z >= Float{-1} && z <= Float{1}) + return Number_O::make_float((Float)std::acos((Float2)z)); + + return Complex_O::create(Number_O::make_float((z > Float{0.0}) ? Float{0.0} : std::numbers::pi_v), + Number_O::make_float(std::asinh(std::copysign(std::sqrt(z * z - Float{1.0}), z)))); +} + +inline Number_sp Number_O::acos(const Number_sp x) { + if (x.fixnump()) + return _acos((single_float_t)x.unsafe_fixnum()); +#ifdef CLASP_SHORT_FLOAT + if (x.short_floatp()) + return _acos(x.unsafe_short_float()); +#endif + if (x.single_floatp()) +#ifdef _TARGET_OS_DARWIN + return _acos(x.unsafe_single_float()); +#else + return _acos(x.unsafe_single_float()); +#endif + return x->acos_(); +} + +inline Number_sp Number_O::tan(Number_sp x) { + if (x.fixnump()) + return SingleFloat_dummy_O::create(std::tan((single_float_t)x.unsafe_fixnum())); +#ifdef CLASP_SHORT_FLOAT + if (x.short_floatp()) + return ShortFloat_O::create(std::tan(x.unsafe_short_float())); +#endif + if (x.single_floatp()) + return SingleFloat_dummy_O::create(std::tan(x.unsafe_single_float())); return x->tan_(); } -inline Number_sp clasp_sinh(Number_sp x) { - if (x.fixnump()) { - float f = x.unsafe_fixnum(); - return clasp_make_single_float(sinhf(f)); - } else if (x.single_floatp()) - return clasp_make_single_float(sinhf(x.unsafe_single_float())); +inline Number_sp Number_O::atan(Number_sp x) { + if (x.fixnump()) +#ifdef _TARGET_OS_DARWIN + return SingleFloat_dummy_O::create(std::atan((double_float_t)x.unsafe_fixnum())); +#else + return SingleFloat_dummy_O::create(std::atan((single_float_t)x.unsafe_fixnum())); +#endif +#ifdef CLASP_SHORT_FLOAT + if (x.short_floatp()) + return ShortFloat_O::create(std::atan(x.unsafe_short_float())); +#endif + if (x.single_floatp()) +#ifdef _TARGET_OS_DARWIN + return SingleFloat_dummy_O::create(std::atan((double_float_t)x.unsafe_single_float())); +#else + return SingleFloat_dummy_O::create(std::atan(x.unsafe_single_float())); +#endif + return x->atan_(); +} + +inline Number_sp Number_O::sinh(Number_sp x) { + if (x.fixnump()) + return SingleFloat_dummy_O::create(std::sinh((single_float_t)x.unsafe_fixnum())); +#ifdef CLASP_SHORT_FLOAT + if (x.single_floatp()) + return ShortFloat_O::create(std::sinh(x.unsafe_short_float())); +#endif + if (x.single_floatp()) + return SingleFloat_dummy_O::create(std::sinh(x.unsafe_single_float())); return x->sinh_(); } -inline Number_sp clasp_cosh(Number_sp x) { - if (x.fixnump()) { - float f = x.unsafe_fixnum(); - return clasp_make_single_float(coshf(f)); - } else if (x.single_floatp()) - return clasp_make_single_float(coshf(x.unsafe_single_float())); + +inline Number_sp Number_O::cosh(Number_sp x) { + if (x.fixnump()) + return SingleFloat_dummy_O::create(std::cosh((single_float_t)x.unsafe_fixnum())); +#ifdef CLASP_SHORT_FLOAT + if (x.short_floatp()) + return ShortFloat_O::create(std::cosh(x.unsafe_short_float())); +#endif + if (x.single_floatp()) + return SingleFloat_dummy_O::create(std::cosh(x.unsafe_single_float())); return x->cosh_(); } -inline Number_sp clasp_tanh(Number_sp x) { - if (x.fixnump()) { - float f = x.unsafe_fixnum(); - return clasp_make_single_float(tanhf(f)); - } else if (x.single_floatp()) - return clasp_make_single_float(tanhf(x.unsafe_single_float())); + +inline Number_sp Number_O::tanh(Number_sp x) { + if (x.fixnump()) + return SingleFloat_dummy_O::create(std::tanh((single_float_t)x.unsafe_fixnum())); +#ifdef CLASP_SHORT_FLOAT + if (x.short_floatp()) + return ShortFloat_O::create(std::tanh(x.unsafe_short_float())); +#endif + if (x.single_floatp()) + return SingleFloat_dummy_O::create(std::tanh(x.unsafe_single_float())); return x->tanh_(); } -inline Number_sp clasp_conjugate(Number_sp x) { - if (gc::IsA(x)) - return gc::As_unsafe(x)->conjugate(); - else - return x; +inline Real_sp Number_O::realpart(const Number_sp x) { +#ifdef CLASP_SHORT_FLOAT + if (x.fixnump() || x.single_floatp() || x.short_floatp()) + return x.as_unsafe(); +#else + if (x.fixnump() || x.single_floatp()) + return x.as_unsafe(); +#endif + return x->realpart_(); } -inline bool clasp_float_nan_p(Float_sp num) { - if (num.single_floatp()) { - float f = num.unsafe_single_float(); - return std::isnan(f); - } - return num->isnan_(); +inline Real_sp Number_O::imagpart(const Number_sp x) { + if (x.fixnump()) + return clasp_make_fixnum(0); +#ifdef CLASP_SHORT_FLOAT + if (x.short_floatp()) + return make_float(std::copysign(short_float_t{0.0}, x.unsafe_short_float())); +#endif + if (x.single_floatp()) + return make_float(std::copysign(single_float_t{0.0}, x.unsafe_single_float())); + return x->imagpart_(); } -inline bool clasp_float_infinity_p(Float_sp num) { - if (num.single_floatp()) { - float f = num.unsafe_single_float(); - return std::isinf(f); +inline Number_sp Number_O::negate(const Number_sp num) { + if (num.fixnump()) { + gc::Fixnum fixnum = num.unsafe_fixnum(); + if (fixnum == MOST_NEGATIVE_FIXNUM) { + // will overflow to a bignum when negated + fixnum = (MOST_POSITIVE_FIXNUM + 1); + return Integer_O::create(fixnum); + } else + return immediate_fixnum(-fixnum); } - // test for isinf not for isnan, good old friend copy paste - return num->isinf_(); +#ifdef CLASP_SHORT_FLOAT + if (num.short_floatp()) + return ShortFloat_O::create(-num.unsafe_short_float()); +#endif + if (num.single_floatp()) + return SingleFloat_dummy_O::create(-num.unsafe_single_float()); + return num->negate_(); } }; // namespace core diff --git a/include/clasp/core/object.h b/include/clasp/core/object.h index cfb32890db..0e62f3e84d 100644 --- a/include/clasp/core/object.h +++ b/include/clasp/core/object.h @@ -102,8 +102,8 @@ FORWARD(General); class RootClass { public: static core::Symbol_sp static_classSymbol() { return UNDEFINED_SYMBOL; }; - static void set_static_creator(gc::smart_ptr cb){}; - explicit RootClass(){}; + static void set_static_creator(gc::smart_ptr cb) {}; + explicit RootClass() {}; }; template struct LispBases1 { @@ -206,11 +206,11 @@ class HashGenerator : public HashGeneratorBase { , _debug(debug) #endif - { + { #ifdef DEBUG_HASH_GENERATOR // if (this->_debug) lisp_write(fmt::format("{} ctor HG@{}\n", CPP_SOURCE(), (void*)this)); #endif - }; + }; /*! Return true if can still accept parts */ bool isFilling() const { return (this->_NextPartIndex < MaxParts) || (this->_Depth >= MaxDepth); } @@ -375,7 +375,7 @@ class T_O : public RootClass { private: friend class CoreExposer; LISP_ABSTRACT_CLASS(core, ClPkg, T_O, "T", ::RootClass); - T_O(){}; + T_O() {}; }; }; // namespace core @@ -395,7 +395,7 @@ class General_O : public T_O { LISP_CLASS(core, CorePkg, General_O, "General", T_O); public: - General_O(){}; + General_O() {}; virtual void sxhash_(HashGenerator& hg) const; virtual void sxhash_equal(HashGenerator& hg) const; @@ -406,8 +406,8 @@ class General_O : public T_O { virtual void validateCodePointer(void** funcPtr, size_t sizeofFuncPtr) { // Do nothing currently } - virtual void fixupInternalsForSnapshotSaveLoad(snapshotSaveLoad::Fixup* fixup){ - // Do nothing by default + virtual void fixupInternalsForSnapshotSaveLoad(snapshotSaveLoad::Fixup* fixup) { + // Do nothing by default }; virtual void fixupOneCodePointer(snapshotSaveLoad::Fixup* fixup, void** address) { printf("%s:%d:%s Should never be called - subclass must implement\n", __FILE__, __LINE__, __FUNCTION__); @@ -511,15 +511,14 @@ inline CL_DEFUN bool cl__eql(T_sp x, T_sp y) { if (x.fixnump()) { return x.raw_() == y.raw_(); } else if (x.single_floatp()) { - if (y.single_floatp()) { - return gc::tagged_single_float_masked(x.raw_()) == gc::tagged_single_float_masked(y.raw_()); - } - return false; + if (!y.single_floatp()) + return false; + single_float_t xf = x.unsafe_single_float(); + single_float_t yf = y.unsafe_single_float(); + // signbit is included in the comparison because (EQL 0.0 -0.0) is non-NIL. + return xf == yf && std::signbit(xf) == std::signbit(yf); } else if (x.characterp()) { - if (y.characterp()) { - return x.unsafe_character() == y.unsafe_character(); - } - return false; + return y.characterp() && x.unsafe_character() == y.unsafe_character(); } else if (x.consp()) { return x.raw_() == y.raw_(); } else if (x.generalp()) { @@ -579,7 +578,7 @@ inline void clasp_sxhash(T_sp obj, HashGenerator& hg) { return; } else if (obj.single_floatp()) { float value = obj.unsafe_single_float(); - hg.addValue((std::fpclassify(value) == FP_ZERO) ? 0u : float_convert::to_bits(value)); + hg.addValue((std::fpclassify(value) == FP_ZERO) ? 0u : float_convert::float_to_bits(value)); return; } else if (obj.characterp()) { hg.addValue(obj.unsafe_character()); @@ -601,7 +600,7 @@ inline void clasp_sxhash(T_sp obj, Hash1Generator& hg) { return; } else if (obj.single_floatp()) { float value = obj.unsafe_single_float(); - hg.addValue((std::fpclassify(value) == FP_ZERO) ? 0u : float_convert::to_bits(value)); + hg.addValue((std::fpclassify(value) == FP_ZERO) ? 0u : float_convert::float_to_bits(value)); return; } else if (obj.characterp()) { hg.addValue(obj.unsafe_character()); diff --git a/include/clasp/core/translators.h b/include/clasp/core/translators.h index 4f2a310b86..19cf97e407 100644 --- a/include/clasp/core/translators.h +++ b/include/clasp/core/translators.h @@ -87,13 +87,13 @@ template <> struct from_object { template <> struct from_object { typedef long double DeclareType; DeclareType _v; - from_object(core::T_sp o) : _v(core::clasp_to_long_double(gc::As(o))) {}; + from_object(core::T_sp o) : _v(core::clasp_to_long_float(gc::As(o))) {}; }; template <> struct from_object { typedef long double DeclareType; DeclareType _v; - from_object(core::T_sp o) : _v(core::clasp_to_long_double(gc::As(o))) {}; + from_object(core::T_sp o) : _v(core::clasp_to_long_float(gc::As(o))) {}; }; template <> struct from_object { @@ -214,16 +214,12 @@ template <> struct to_object { template <> struct to_object { typedef long double DeclareType; - static core::T_sp convert(DeclareType v) { - return core::clasp_make_double_float(static_cast(v)); - } + static core::T_sp convert(DeclareType v) { return core::LongFloat_O::create(v); } }; template <> struct to_object { typedef const long double& DeclareType; - static core::T_sp convert(DeclareType v) { - return core::clasp_make_double_float(static_cast(v)); - } + static core::T_sp convert(DeclareType v) { return core::LongFloat_O::create(v); } }; template <> struct to_object { diff --git a/include/clasp/gctools/configure_memory.h b/include/clasp/gctools/configure_memory.h index 5a135f356c..624b624552 100644 --- a/include/clasp/gctools/configure_memory.h +++ b/include/clasp/gctools/configure_memory.h @@ -42,14 +42,21 @@ #define FIXNUM0_TAG 0x00 #define FIXNUM1_TAG 0x04 // fixnum means lower two bits are zero so two tags #define FIXNUM_SHIFT 2 -#define GENERAL_TAG 0x01 -#define CHARACTER_TAG 0x02 +#define GENERAL_TAG 0b001 +#define CHARACTER_TAG 0b010 +#define CHARACTER_SHIFT TAG_BITS #define CONS_TAG 0x03 #define VASLIST0_TAG 0x05 -#define SINGLE_FLOAT_TAG 0x06 #define UNBOUND_TAG 0x07 +#ifdef CLASP_SHORT_FLOAT +#define SHORT_FLOAT_TAG 0b1100 +#define SINGLE_FLOAT_TAG 0b1101 +#define SHORT_FLOAT_SHIFT (TAG_BITS + 1) +#define SINGLE_FLOAT_SHIFT (TAG_BITS + 1) +#else +#define SINGLE_FLOAT_TAG 0b110 #define SINGLE_FLOAT_SHIFT TAG_BITS -#define CHARACTER_SHIFT TAG_BITS +#endif #if TAG_BITS == 3 #define CLASP_ALIGNMENT 8 #define ZERO_TAG_MASK 0x07 diff --git a/include/clasp/gctools/gc_boot.h b/include/clasp/gctools/gc_boot.h index 49dcf0db9c..1b69884216 100644 --- a/include/clasp/gctools/gc_boot.h +++ b/include/clasp/gctools/gc_boot.h @@ -40,6 +40,7 @@ enum Data_types { CONSTANT_ARRAY_OFFSET, ctype_double, ctype_float, + ctype_long_double, ctype_int, ctype_short, ctype_unsigned_char, diff --git a/include/clasp/gctools/gcarray.h b/include/clasp/gctools/gcarray.h index 9e89af116e..994cb20251 100644 --- a/include/clasp/gctools/gcarray.h +++ b/include/clasp/gctools/gcarray.h @@ -30,9 +30,12 @@ THE SOFTWARE. namespace gctools { -template class GCArray_moveable : public GCContainer { +// The following class is packed to ensure that no padding is inserted +// before _MaybeSignedLength. Padding will break our non-virtual +// length method. +template class __attribute__((__packed__)) GCArray_moveable : public GCContainer { public: - GCArray_moveable(){}; + GCArray_moveable() {}; public: typedef T value_type; @@ -92,7 +95,7 @@ template class GCArray_moveable : public GCContainer { // how C++ reference semantics work. template class GCArray_atomic : public GCContainer { public: - GCArray_atomic(){}; + GCArray_atomic() {}; public: int64_t _Length; // Index one beyond the total number of elements allocated @@ -130,7 +133,7 @@ template void Array0_dump(const Array& v, const char* head = "" template class GCArraySignedLength_moveable : public GCArray_moveable { public: - GCArraySignedLength_moveable(){}; + GCArraySignedLength_moveable() {}; public: GCArraySignedLength_moveable(int64_t length, const T& initialElement, bool initialElementSupplied, size_t initialContentsSize = 0, diff --git a/include/clasp/gctools/pointer_tagging.h b/include/clasp/gctools/pointer_tagging.h index bc38b47a06..6a502ea082 100644 --- a/include/clasp/gctools/pointer_tagging.h +++ b/include/clasp/gctools/pointer_tagging.h @@ -210,6 +210,11 @@ static const uintptr_t character_shift = CHARACTER_SHIFT; static const uintptr_t single_float_tag = SINGLE_FLOAT_TAG; static const uintptr_t single_float_shift = SINGLE_FLOAT_SHIFT; static const uintptr_t single_float_mask = 0x1FFFFFFFFF; // single-floats are in these 32+5bits +#ifdef CLASP_SHORT_FLOAT +static const uintptr_t short_float_tag = SHORT_FLOAT_TAG; +static const uintptr_t short_float_shift = SHORT_FLOAT_SHIFT; +static const uintptr_t short_float_mask = 0x1FFFFFFFFF; // single-floats are in these 32+5bits +#endif /* These values define the Stamp ranges for different kinds of objects. There are the following kinds of objects: @@ -234,6 +239,9 @@ static const uintptr_t unshifted_stamp_first_instance = 65536; static const char* tagged_fixnum_str = "FIXNUM"; static const char* tagged_character_str = "CHARACTER"; static const char* tagged_single_float_str = "SINGLE-FLOAT"; +#ifdef CLASP_SHORT_FLOAT +static const char* tagged_short_float_str = "SHORT-FLOAT"; +#endif static const char* tagged_object_str = "OBJECT"; static const char* tagged_cons_str = "CONS"; static const char* tagged_unbound_str = "UNBOUND"; @@ -332,6 +340,7 @@ template inline claspCharacter untag_character(T ptr) { template inline bool tagged_characterp(T ptr) { return ((reinterpret_cast(ptr) & immediate_mask) == character_tag); }; + template inline T tag_single_float(float fn) { GCTOOLS_ASSERT(sizeof(uintptr_t) == 8); GCTOOLS_ASSERT(sizeof(float) == 4); @@ -356,6 +365,32 @@ template inline bool tagged_single_floatp(T ptr) { return ((reinterpret_cast(ptr) & immediate_mask) == single_float_tag); }; +#ifdef CLASP_SHORT_FLOAT +template inline T tag_short_float(float fn) { + GCTOOLS_ASSERT(sizeof(uintptr_t) == 8); + GCTOOLS_ASSERT(sizeof(float) == 4); + uintptr_t val; + memcpy(&val, &fn, sizeof(fn)); + return reinterpret_cast((val << short_float_shift) + short_float_tag); +} +template inline uintptr_t tagged_short_float_masked(T const ptr) { + return reinterpret_cast(reinterpret_cast(ptr) & short_float_mask); +} +template inline float untag_short_float(T const ptr) { + GCTOOLS_ASSERT((reinterpret_cast(ptr) & immediate_mask) == short_float_tag); + GCTOOLS_ASSERT(sizeof(uintptr_t) == 8); + GCTOOLS_ASSERT(sizeof(float) == 4); + uintptr_t val(reinterpret_cast(ptr)); + float result; + val >>= short_float_shift; + memcpy(&result, &val, sizeof(result)); + return result; +} +template inline bool tagged_short_floatp(T ptr) { + return ((reinterpret_cast(ptr) & immediate_mask) == short_float_tag); +}; +#endif + template inline bool tagged_generalp(T ptr) { return ((uintptr_t)(ptr)&ptag_mask) == general_tag; } template inline bool tagged_vaslistp(T ptr) { @@ -415,6 +450,12 @@ template std::string tag_str(T tagged_obj) { return std::string(tagged_single_float_str); } +#ifdef CLASP_SHORT_FLOAT + if (tagged_short_floatp(tagged_obj)) { + return std::string(tagged_short_float_str); + } +#endif + if (tagged_generalp(tagged_obj)) { return std::string(tagged_general_str); } diff --git a/include/clasp/gctools/smart_pointers.h b/include/clasp/gctools/smart_pointers.h index 9daf114063..9d2f28e1ec 100644 --- a/include/clasp/gctools/smart_pointers.h +++ b/include/clasp/gctools/smart_pointers.h @@ -124,8 +124,11 @@ template class tagged_ptr { bool same_as_keyP() const { return tagged_same_as_keyp(this->theObject); }; bool characterp() const { return tagged_characterp(this->theObject); }; claspCharacter unsafe_character() const { return untag_character(this->theObject); }; - bool single_floatp() const { return tagged_single_floatp(this->theObject); }; float unsafe_single_float() const { return untag_single_float(this->theObject); }; +#ifdef CLASP_SHORT_FLOAT + bool short_floatp() const { return tagged_short_floatp(this->theObject); }; + short_float_t unsafe_short_float() const { return untag_short_float(this->theObject); }; +#endif // This replaces pointerp() bool objectp() const { return this->generalp() || this->consp(); }; bool generalp() const { return tagged_generalp(this->theObject); }; @@ -364,6 +367,10 @@ template class base_ptr /*: public tagged_ptr*/ { claspCharacter unsafe_character() const { return untag_character(this->theObject); }; bool single_floatp() const { return tagged_single_floatp(this->theObject); }; float unsafe_single_float() const { return untag_single_float(this->theObject); }; +#ifdef CLASP_SHORT_FLOAT + bool short_floatp() const { return tagged_short_floatp(this->theObject); }; + short_float_t unsafe_short_float() const { return untag_short_float(this->theObject); }; +#endif Fixnum asFixnum() const { GCTOOLS_ASSERT(this->fixnump()); return untag_fixnum(this->theObject); @@ -709,6 +716,10 @@ template <> class smart_ptr { // : public tagged_ptr { inline Fixnum unsafe_fixnum() const { return untag_fixnum(this->theObject); }; bool single_floatp() const { return tagged_single_floatp(this->theObject); }; float unsafe_single_float() const { return untag_single_float(this->theObject); }; +#ifdef CLASP_SHORT_FLOAT + bool short_floatp() const { return tagged_short_floatp(this->theObject); }; + float unsafe_short_float() const { return untag_short_float(this->theObject); }; +#endif bool valistp() const { return tagged_vaslistp(this->theObject); }; void* unsafe_valist() const { return untag_vaslist(this->theObject); }; void* safe_valist() const { @@ -895,6 +906,10 @@ template <> class smart_ptr : public base_ptr { claspCharacter unsafe_character() const { return untag_character(this->theObject); }; bool single_floatp() const { return tagged_single_floatp(this->theObject); }; float unsafe_single_float() const { return untag_single_float(this->theObject); }; +#ifdef CLASP_SHORT_FLOAT + bool short_floatp() const { return tagged_short_floatp(this->theObject); }; + short_float_t unsafe_short_float() const { return untag_short_float(this->theObject); }; +#endif // This replaces pointerp() bool objectp() const { return this->generalp() || this->consp(); }; bool generalp() const { return tagged_generalp(this->theObject); }; @@ -1058,6 +1073,10 @@ template <> class smart_ptr : public base_ptrtheObject); }; bool single_floatp() const { return tagged_single_floatp(this->theObject); }; float unsafe_single_float() const { return untag_single_float(this->theObject); }; +#ifdef CLASP_SHORT_FLOAT + bool short_floatp() const { return tagged_short_floatp(this->theObject); }; + short_float_t unsafe_short_float() const { return untag_short_float(this->theObject); }; +#endif // This replaces pointerp() bool objectp() const { return this->generalp() || this->consp(); }; bool generalp() const { return tagged_generalp(this->theObject); }; @@ -1219,6 +1238,10 @@ template <> class smart_ptr : public base_ptrtheObject); }; bool single_floatp() const { return tagged_single_floatp(this->theObject); }; float unsafe_single_float() const { return untag_single_float(this->theObject); }; +#ifdef CLASP_SHORT_FLOAT + bool short_floatp() const { return tagged_short_floatp(this->theObject); }; + short_float_t unsafe_short_float() const { return untag_short_float(this->theObject); }; +#endif // This replaces pointerp() bool objectp() const { return this->generalp() || this->consp(); }; bool generalp() const { return tagged_generalp(this->theObject); }; diff --git a/include/clasp/gctools/tagged_cast.h b/include/clasp/gctools/tagged_cast.h index dc944fe845..e21a1b0582 100644 --- a/include/clasp/gctools/tagged_cast.h +++ b/include/clasp/gctools/tagged_cast.h @@ -32,6 +32,9 @@ template struct TaggedCast { namespace core { class Fixnum_I {}; +#ifdef CLASP_SHORT_FLOAT +class ShortFloat_I {}; +#endif class SingleFloat_I {}; class Character_I {}; class Integer_O; @@ -42,7 +45,6 @@ class T_O; class Instance_O; class Float_O; typedef Fixnum_I Fixnum_O; -typedef SingleFloat_I SingleFloat_O; typedef Character_I Character_O; }; // namespace core @@ -156,11 +158,26 @@ template <> struct TaggedCast { return NULL; } }; +#ifdef CLASP_SHORT_FLOAT +template <> struct TaggedCast { + typedef core::Real_O* ToType; + typedef core::ShortFloat_I* FromType; + inline static bool isA(FromType ptr) { return true; } + inline static ToType castOrNULL(FromType client) { + if (TaggedCast::isA(client)) + return reinterpret_cast(client); + return NULL; + } +}; +#endif template struct TaggedCast { typedef core::Real_O* ToType; typedef FROM FromType; inline static bool isA(FromType ptr) { return tagged_fixnump(ptr) || tagged_single_floatp(ptr) || +#ifdef CLASP_SHORT_FLOAT + tagged_short_floatp(ptr) || +#endif (tagged_generalp(ptr) && (FromGeneralCast::isA((core::General_O*)untag_general(ptr)))); } inline static ToType castOrNULL(FromType client) { @@ -200,6 +217,18 @@ template <> struct TaggedCast { return NULL; } }; +#ifdef CLASP_SHORT_FLOAT +template <> struct TaggedCast { + typedef core::Number_O* ToType; + typedef core::ShortFloat_I* FromType; + inline static bool isA(FromType ptr) { return true; } + inline static ToType castOrNULL(FromType client) { + if (TaggedCast::isA(client)) + return reinterpret_cast(client); + return NULL; + } +}; +#endif }; // namespace gctools namespace gctools { @@ -208,6 +237,9 @@ template struct TaggedCast { typedef FROM FromType; inline static bool isA(FromType ptr) { return tagged_fixnump(ptr) || tagged_single_floatp(ptr) || +#ifdef CLASP_SHORT_FLOAT + tagged_short_floatp(ptr) || +#endif (tagged_generalp(ptr) && (FromGeneralCast::isA((core::General_O*)untag_general(ptr)))); } inline static ToType castOrNULL(FromType client) { @@ -256,6 +288,18 @@ template <> struct TaggedCast { return NULL; } }; +#ifdef CLASP_SHORT_FLOAT +template <> struct TaggedCast { + typedef core::T_O* ToType; + typedef core::ShortFloat_I* FromType; + inline static bool isA(FromType ptr) { return true; } + inline static ToType castOrNULL(FromType client) { + if (TaggedCast::isA(client)) + return reinterpret_cast(client); + return NULL; + } +}; +#endif template <> struct TaggedCast { typedef core::T_O* ToType; typedef core::Character_I* FromType; @@ -285,6 +329,14 @@ template <> struct TaggedCast { inline static bool isA(FromType ptr) { return true; } inline static ToType castOrNULL(FromType client) { return client; } }; +#ifdef CLASP_SHORT_FLOAT +template <> struct TaggedCast { + typedef core::ShortFloat_I* ToType; + typedef core::ShortFloat_I* FromType; + inline static bool isA(FromType ptr) { return true; } + inline static ToType castOrNULL(FromType client) { return client; } +}; +#endif // Cast from anything to SingleFloat_I* template struct TaggedCast { typedef core::SingleFloat_I* ToType; @@ -297,6 +349,19 @@ template struct TaggedCast { return NULL; } }; +#ifdef CLASP_SHORT_FLOAT +template struct TaggedCast { + typedef core::ShortFloat_I* ToType; + typedef FROM FromType; + inline static bool isA(FromType ptr) { return tagged_short_floatp(ptr); } + inline static ToType castOrNULL(FromType client) { + if (TaggedCast::isA(client)) { + return reinterpret_cast(client); + } + return NULL; + } +}; +#endif template <> struct TaggedCast { typedef core::Float_O* ToType; @@ -314,12 +379,27 @@ template <> struct TaggedCast { return NULL; } }; +#ifdef CLASP_SHORT_FLOAT +template <> struct TaggedCast { + typedef core::Float_O* ToType; + typedef core::ShortFloat_I* FromType; + inline static bool isA(FromType ptr) { return true; }; + inline static ToType castOrNULL(FromType client) { + if (TaggedCast::isA(client)) + return reinterpret_cast(client); + return NULL; + } +}; +#endif template struct TaggedCast { typedef core::Float_O* ToType; typedef FROM FromType; inline static bool isA(FromType ptr) { return tagged_single_floatp(ptr) || +#ifdef CLASP_SHORT_FLOAT + tagged_short_floatp(ptr) || +#endif (tagged_generalp(ptr) && (FromGeneralCast::isA((core::General_O*)untag_general(ptr)))); } inline static ToType castOrNULL(FromType client) { diff --git a/include/clasp/llvmo/intrinsics.h b/include/clasp/llvmo/intrinsics.h index a221fa0646..9f929559aa 100644 --- a/include/clasp/llvmo/intrinsics.h +++ b/include/clasp/llvmo/intrinsics.h @@ -96,8 +96,11 @@ LtvcReturn ltvc_ensure_vcell(gctools::GCRootsInModule* holder, char tag, size_t LtvcReturn ltvc_make_package(gctools::GCRootsInModule* holder, char tag, size_t index, core::T_O* package_name_t); LtvcReturn ltvc_make_random_state(gctools::GCRootsInModule* holder, char tag, size_t index, core::T_O* random_state_string_t); LtvcReturn ltvc_find_class(gctools::GCRootsInModule* holder, char tag, size_t index, core::T_O* class_name_t); -LtvcReturn ltvc_make_float(gctools::GCRootsInModule* holder, char tag, size_t index, float f); -LtvcReturn ltvc_make_double(gctools::GCRootsInModule* holder, char tag, size_t index, double f); +LtvcReturn ltvc_make_binary16(gctools::GCRootsInModule* holder, char tag, size_t index, core::short_float_t f); +LtvcReturn ltvc_make_binary32(gctools::GCRootsInModule* holder, char tag, size_t index, core::single_float_t f); +LtvcReturn ltvc_make_binary64(gctools::GCRootsInModule* holder, char tag, size_t index, core::double_float_t f); +LtvcReturn ltvc_make_binary80(gctools::GCRootsInModule* holder, char tag, size_t index, core::long_float_t f); +LtvcReturn ltvc_make_binary128(gctools::GCRootsInModule* holder, char tag, size_t index, core::long_float_t f); LtvcReturn ltvc_enclose(gctools::GCRootsInModule* holder, char tag, size_t index, core::T_O* lambdaName, size_t function_index, size_t function_info_index); LtvcReturn ltvc_allocate_instance(gctools::GCRootsInModule* holder, char tag, size_t index, core::T_O* klass); diff --git a/src/analysis/clasp_gc.sif b/src/analysis/clasp_gc.sif index b4797b00d9..306ec7b16b 100644 --- a/src/analysis/clasp_gc.sif +++ b/src/analysis/clasp_gc.sif @@ -19,7 +19,7 @@ "core::BindingDynEnv_O" "core::AbstractSimpleVector_O" "core::SimpleMDArray_byte16_t_O" "core::Pathname_O" "core::Str8Ns_O" "core::SimpleVector_byte4_t_O" "llvmo::UndefValue_O" "llvmo::CallBase_O" - "core::Path_O" "mp::SharedMutex_O" + "core::Path_O" "mp::SharedMutex_O" "core::ComplexVector_long_float_O" "asttooling::DerivableASTFrontendAction" "core::InstanceCreator_O" "core::Scope_O" "core::BytecodeDebugLocation_O" "llvmo::InsertPoint_O" "core::FunctionDescription_O" "core::ComplexVector_double_O" @@ -50,7 +50,8 @@ "core::KeywordArgument" "llvmo::Module_O" "core::SingleFloat_dummy_O" "llvmo::DIExpression_O" "llvmo::InvokeInst_O" "core::StrNs_O" "comp::GlobalFunInfo_O" "clasp_ffi::ForeignData_O" "llvmo::CallInst_O" - "core::BytecodeAstDecls_O" "core::DoubleFloat_O" "core::DebuggerFrame_O" + "core::BytecodeAstDecls_O" "core::DoubleFloat_O" + "core::ComplexVector_short_float_O" "core::DebuggerFrame_O" "comp::LocalMacroInfo_O" "comp::LexFixup_O" "core::StringStream_O" "llvmo::LibraryBase_O" "core::Sigset_O" "core::MDArray_int32_t_O" "asttooling::AsttoolingExposer_O" "llvmo::IntegerType_O" @@ -62,15 +63,15 @@ "llvmo::LLVMContext_O" "core::MDArray_int4_t_O" "core::WeakKeyHashTable_O" "core::Rack_O" "core::MDArrayBaseChar_O" "core::UserData_O" "core::ExternalObject_O" "llvmo::DINode_O" - "llvmo::GlobalVariable_O" "core::BroadcastStream_O" "core::General_O" - "llvmo::MemoryBuffer_O" "llvmo::ObjectFile_O" "core::BytecodeSimpleFun_O" - "llvmo::Library_O" "core::Closure_O" "core::ComplexVector_size_t_O" - "comp::RestoreSPFixup_O" "mpip::Mpi_O" "llvmo::DINodeArray_O" - "llvmo::ConstantDataArray_O" "core::SmallMap_O" "core::Instance_O" - "llvmo::TargetOptions_O" "core::CoreFunGenerator_O" - "clasp_ffi::ForeignTypeSpec_O" "core::Unused_dummy_O" - "llvmo::DWARFContext_O" "core::HashTableEqual_O" "llvmo::Triple_O" - "core::SimpleMDArray_byte64_t_O" "core::BitVectorNs_O" + "llvmo::GlobalVariable_O" "core::SimpleVector_short_float_O" + "core::BroadcastStream_O" "core::General_O" "llvmo::MemoryBuffer_O" + "llvmo::ObjectFile_O" "core::BytecodeSimpleFun_O" "llvmo::Library_O" + "core::Closure_O" "core::ComplexVector_size_t_O" "comp::RestoreSPFixup_O" + "mpip::Mpi_O" "llvmo::DINodeArray_O" "llvmo::ConstantDataArray_O" + "core::SmallMap_O" "core::Instance_O" "llvmo::TargetOptions_O" + "core::CoreFunGenerator_O" "clasp_ffi::ForeignTypeSpec_O" + "core::Unused_dummy_O" "llvmo::DWARFContext_O" "core::HashTableEqual_O" + "llvmo::Triple_O" "core::SimpleMDArray_byte64_t_O" "core::BitVectorNs_O" "core::CoreExposer_O" "core::BytecodeDebugVars_O" "comp::JumpIfSuppliedFixup_O" "core::KeyValuePair" "llvmo::NamedMDNode_O" "core::SimpleVector_byte16_t_O" "llvmo::ThreadSafeContext_O" @@ -107,16 +108,19 @@ "core::MDArray_byte4_t_O" "llvmo::Argument_O" "core::Iterator_O" "llvmo::IRBuilderBase_O" "core::Null_O" "core::RequiredArgument" "core::SingleDispatchMethod_O" "comp::VarInfo_O" "core::CxxObject_O" - "llvmo::ReturnInst_O" "llvmo::FunctionType_O" "clbind::DummyCreator_O" + "core::SimpleVector_long_float_O" "llvmo::ReturnInst_O" + "llvmo::FunctionType_O" "clbind::DummyCreator_O" "core::MDArray_byte16_t_O" "llvmo::DIContext_O" "llvmo::JITDylib_O" "llvmo::Type_O" "core::Pointer_O" "llvmo::UnreachableInst_O" - "core::ComplexVector_int64_t_O" "core::FileScope_O" "core::Float_O" + "core::ComplexVector_int64_t_O" "core::SimpleMDArray_short_float_O" + "core::SimpleMDArray_long_float_O" "core::FileScope_O" "core::Float_O" "core::SimpleMDArray_byte4_t_O" "llvmo::DIDerivedType_O" "comp::EntryCloseFixup_O" "core::SimpleVector_int64_t_O" "llvmo::ConstantDataSequential_O" "comp::EntryFixup_O" - "core::MDArray_double_O" "llvmo::StoreInst_O" "llvmo::DebugLoc_O" - "core::WeakPointer_O" "core::DestDynEnv_O" "comp::Annotation_O" - "core::DynEnv_O" "core::BytecodeAstBlock_O" "comp::LexSetFixup_O" + "core::MDArray_short_float_O" "core::MDArray_double_O" + "llvmo::StoreInst_O" "llvmo::DebugLoc_O" "core::WeakPointer_O" + "core::DestDynEnv_O" "comp::Annotation_O" "core::DynEnv_O" + "core::BytecodeAstBlock_O" "comp::LexSetFixup_O" "core::SimpleMDArray_byte8_t_O" "comp::SymbolMacroVarInfo_O" "core::UnwindProtectDynEnv_O" "comp::LexicalInfo_O" "llvmo::Instruction_O" "core::FileStream_O" "comp::ExitFixup_O" @@ -139,13 +143,14 @@ "core::SynonymStream_O" "core::BytecodeModule_O" "core::Ratio_O" "core::MDArray_int2_t_O" "core::ComplexVector_byte2_t_O" "llvmo::ExecutionEngine_O" "core::ClassRepCreator_O" - "core::SimpleVector_int16_t_O" "llvmo::Attribute_O" - "core::DerivableCxxObject_O" "core::SymbolToEnumConverter_O" - "llvmo::SwitchInst_O" "core::SingleDispatchGenericFunction_O" - "core::ComplexVector_int32_t_O" "core::ComplexVector_byte4_t_O" - "asttooling::SourceLocation_O" "core::LogicalPathname_O" - "llvmo::TargetSubtargetInfo_O" "core::SimpleVector_double_O" - "core::CFileStream_O" "core::SimpleMDArray_byte32_t_O" "core::Bignum_O" + "core::MDArray_long_float_O" "core::SimpleVector_int16_t_O" + "llvmo::Attribute_O" "core::DerivableCxxObject_O" + "core::SymbolToEnumConverter_O" "llvmo::SwitchInst_O" + "core::SingleDispatchGenericFunction_O" "core::ComplexVector_int32_t_O" + "core::ComplexVector_byte4_t_O" "asttooling::SourceLocation_O" + "core::LogicalPathname_O" "llvmo::TargetSubtargetInfo_O" + "core::SimpleVector_double_O" "core::CFileStream_O" + "core::SimpleMDArray_byte32_t_O" "core::Bignum_O" "llvmo::LLVMTargetMachine_O" "core::ClassHolder_O" "core::ComplexVector_byte32_t_O" "llvmo::UnaryInstruction_O" "llvmo::GlobalValue_O" "llvmo::PointerType_O" "core::TwoWayStream_O")} @@ -1209,6 +1214,35 @@ :length-field-names ("_Dimensions" "._MaybeSignedLength") :end-field-names ("_Dimensions" "._MaybeSignedLength")} {variable-field-only :offset-type-cxx-identifier "ctype_unsigned_long" :fixup-type "unsigned long"} +{class-kind :stamp-name "STAMPWTAG_core__MDArray_short_float_O" + :stamp-key "core::MDArray_short_float_O" + :parent-class "core::template_Array" + :lisp-class-base "core::MDArray_O" :root-class "core::T_O" :stamp-wtag 3 + :definition-data "IS_POLYMORPHIC"} +{fixed-field :offset-type-cxx-identifier "CONSTANT_ARRAY_OFFSET" :offset-ctype "UnknownType" + :offset-base-ctype "core::MDArray_short_float_O" + :layout-offset-field-names ("_Length")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::MDArray_short_float_O" + :layout-offset-field-names ("_FillPointerOrLengthOrDummy")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::MDArray_short_float_O" + :layout-offset-field-names ("_ArrayTotalSize")} +{fixed-field :offset-type-cxx-identifier "SMART_PTR_OFFSET" + :offset-ctype "gctools::smart_ptr" + :offset-base-ctype "core::MDArray_short_float_O" :layout-offset-field-names ("_Data")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::MDArray_short_float_O" + :layout-offset-field-names ("_DisplacedIndexOffset")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::MDArray_short_float_O" + :layout-offset-field-names ("_Flags" "._Flags")} +{variable-array0 :offset-base-ctype "core::MDArray_short_float_O" + :field-names ("_Dimensions" "._Data")} +{variable-capacity :ctype "unsigned long" :offset-base-ctype "core::MDArray_short_float_O" + :length-field-names ("_Dimensions" "._MaybeSignedLength") + :end-field-names ("_Dimensions" "._MaybeSignedLength")} +{variable-field-only :offset-type-cxx-identifier "ctype_unsigned_long" :fixup-type "unsigned long"} {class-kind :stamp-name "STAMPWTAG_core__MDArray_int16_t_O" :stamp-key "core::MDArray_int16_t_O" :parent-class "core::template_Array" :lisp-class-base "core::MDArray_O" :root-class "core::T_O" :stamp-wtag 3 @@ -1235,6 +1269,34 @@ :length-field-names ("_Dimensions" "._MaybeSignedLength") :end-field-names ("_Dimensions" "._MaybeSignedLength")} {variable-field-only :offset-type-cxx-identifier "ctype_unsigned_long" :fixup-type "unsigned long"} +{class-kind :stamp-name "STAMPWTAG_core__MDArray_long_float_O" + :stamp-key "core::MDArray_long_float_O" + :parent-class "core::template_Array" + :lisp-class-base "core::MDArray_O" :root-class "core::T_O" :stamp-wtag 3 + :definition-data "IS_POLYMORPHIC"} +{fixed-field :offset-type-cxx-identifier "CONSTANT_ARRAY_OFFSET" :offset-ctype "UnknownType" + :offset-base-ctype "core::MDArray_long_float_O" :layout-offset-field-names ("_Length")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::MDArray_long_float_O" + :layout-offset-field-names ("_FillPointerOrLengthOrDummy")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::MDArray_long_float_O" + :layout-offset-field-names ("_ArrayTotalSize")} +{fixed-field :offset-type-cxx-identifier "SMART_PTR_OFFSET" + :offset-ctype "gctools::smart_ptr" + :offset-base-ctype "core::MDArray_long_float_O" :layout-offset-field-names ("_Data")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::MDArray_long_float_O" + :layout-offset-field-names ("_DisplacedIndexOffset")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::MDArray_long_float_O" + :layout-offset-field-names ("_Flags" "._Flags")} +{variable-array0 :offset-base-ctype "core::MDArray_long_float_O" + :field-names ("_Dimensions" "._Data")} +{variable-capacity :ctype "unsigned long" :offset-base-ctype "core::MDArray_long_float_O" + :length-field-names ("_Dimensions" "._MaybeSignedLength") + :end-field-names ("_Dimensions" "._MaybeSignedLength")} +{variable-field-only :offset-type-cxx-identifier "ctype_unsigned_long" :fixup-type "unsigned long"} {class-kind :stamp-name "STAMPWTAG_core__MDArray_int8_t_O" :stamp-key "core::MDArray_int8_t_O" :parent-class "core::template_Array" :lisp-class-base "core::MDArray_O" :root-class "core::T_O" :stamp-wtag 3 @@ -2023,6 +2085,36 @@ :length-field-names ("_Dimensions" "._MaybeSignedLength") :end-field-names ("_Dimensions" "._MaybeSignedLength")} {variable-field-only :offset-type-cxx-identifier "ctype_unsigned_long" :fixup-type "unsigned long"} +{class-kind :stamp-name "STAMPWTAG_core__SimpleMDArray_long_float_O" + :stamp-key "core::SimpleMDArray_long_float_O" + :parent-class "core::template_SimpleArray" + :lisp-class-base "core::SimpleMDArray_O" :root-class "core::T_O" :stamp-wtag 3 + :definition-data "IS_POLYMORPHIC"} +{fixed-field :offset-type-cxx-identifier "CONSTANT_ARRAY_OFFSET" :offset-ctype "UnknownType" + :offset-base-ctype "core::SimpleMDArray_long_float_O" + :layout-offset-field-names ("_Length")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::SimpleMDArray_long_float_O" + :layout-offset-field-names ("_FillPointerOrLengthOrDummy")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::SimpleMDArray_long_float_O" + :layout-offset-field-names ("_ArrayTotalSize")} +{fixed-field :offset-type-cxx-identifier "SMART_PTR_OFFSET" + :offset-ctype "gctools::smart_ptr" + :offset-base-ctype "core::SimpleMDArray_long_float_O" + :layout-offset-field-names ("_Data")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::SimpleMDArray_long_float_O" + :layout-offset-field-names ("_DisplacedIndexOffset")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::SimpleMDArray_long_float_O" + :layout-offset-field-names ("_Flags" "._Flags")} +{variable-array0 :offset-base-ctype "core::SimpleMDArray_long_float_O" + :field-names ("_Dimensions" "._Data")} +{variable-capacity :ctype "unsigned long" :offset-base-ctype "core::SimpleMDArray_long_float_O" + :length-field-names ("_Dimensions" "._MaybeSignedLength") + :end-field-names ("_Dimensions" "._MaybeSignedLength")} +{variable-field-only :offset-type-cxx-identifier "ctype_unsigned_long" :fixup-type "unsigned long"} {class-kind :stamp-name "STAMPWTAG_core__SimpleMDArrayCharacter_O" :stamp-key "core::SimpleMDArrayCharacter_O" :parent-class "core::template_SimpleArray" @@ -2259,6 +2351,36 @@ :length-field-names ("_Dimensions" "._MaybeSignedLength") :end-field-names ("_Dimensions" "._MaybeSignedLength")} {variable-field-only :offset-type-cxx-identifier "ctype_unsigned_long" :fixup-type "unsigned long"} +{class-kind :stamp-name "STAMPWTAG_core__SimpleMDArray_short_float_O" + :stamp-key "core::SimpleMDArray_short_float_O" + :parent-class "core::template_SimpleArray" + :lisp-class-base "core::SimpleMDArray_O" :root-class "core::T_O" :stamp-wtag 3 + :definition-data "IS_POLYMORPHIC"} +{fixed-field :offset-type-cxx-identifier "CONSTANT_ARRAY_OFFSET" :offset-ctype "UnknownType" + :offset-base-ctype "core::SimpleMDArray_short_float_O" + :layout-offset-field-names ("_Length")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::SimpleMDArray_short_float_O" + :layout-offset-field-names ("_FillPointerOrLengthOrDummy")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::SimpleMDArray_short_float_O" + :layout-offset-field-names ("_ArrayTotalSize")} +{fixed-field :offset-type-cxx-identifier "SMART_PTR_OFFSET" + :offset-ctype "gctools::smart_ptr" + :offset-base-ctype "core::SimpleMDArray_short_float_O" + :layout-offset-field-names ("_Data")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::SimpleMDArray_short_float_O" + :layout-offset-field-names ("_DisplacedIndexOffset")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::SimpleMDArray_short_float_O" + :layout-offset-field-names ("_Flags" "._Flags")} +{variable-array0 :offset-base-ctype "core::SimpleMDArray_short_float_O" + :field-names ("_Dimensions" "._Data")} +{variable-capacity :ctype "unsigned long" :offset-base-ctype "core::SimpleMDArray_short_float_O" + :length-field-names ("_Dimensions" "._MaybeSignedLength") + :end-field-names ("_Dimensions" "._MaybeSignedLength")} +{variable-field-only :offset-type-cxx-identifier "ctype_unsigned_long" :fixup-type "unsigned long"} {class-kind :stamp-name "STAMPWTAG_core__SimpleMDArray_int64_t_O" :stamp-key "core::SimpleMDArray_int64_t_O" :parent-class "core::template_SimpleArray" @@ -2776,6 +2898,36 @@ :length-field-names ("_Dimensions" "._MaybeSignedLength") :end-field-names ("_Dimensions" "._MaybeSignedLength")} {variable-field-only :offset-type-cxx-identifier "ctype_unsigned_long" :fixup-type "unsigned long"} +{class-kind :stamp-name "STAMPWTAG_core__ComplexVector_long_float_O" + :stamp-key "core::ComplexVector_long_float_O" + :parent-class "core::template_Vector" + :lisp-class-base "core::ComplexVector_O" :root-class "core::T_O" :stamp-wtag 3 + :definition-data "IS_POLYMORPHIC"} +{fixed-field :offset-type-cxx-identifier "CONSTANT_ARRAY_OFFSET" :offset-ctype "UnknownType" + :offset-base-ctype "core::ComplexVector_long_float_O" + :layout-offset-field-names ("_Length")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::ComplexVector_long_float_O" + :layout-offset-field-names ("_FillPointerOrLengthOrDummy")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::ComplexVector_long_float_O" + :layout-offset-field-names ("_ArrayTotalSize")} +{fixed-field :offset-type-cxx-identifier "SMART_PTR_OFFSET" + :offset-ctype "gctools::smart_ptr" + :offset-base-ctype "core::ComplexVector_long_float_O" + :layout-offset-field-names ("_Data")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::ComplexVector_long_float_O" + :layout-offset-field-names ("_DisplacedIndexOffset")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::ComplexVector_long_float_O" + :layout-offset-field-names ("_Flags" "._Flags")} +{variable-array0 :offset-base-ctype "core::ComplexVector_long_float_O" + :field-names ("_Dimensions" "._Data")} +{variable-capacity :ctype "unsigned long" :offset-base-ctype "core::ComplexVector_long_float_O" + :length-field-names ("_Dimensions" "._MaybeSignedLength") + :end-field-names ("_Dimensions" "._MaybeSignedLength")} +{variable-field-only :offset-type-cxx-identifier "ctype_unsigned_long" :fixup-type "unsigned long"} {class-kind :stamp-name "STAMPWTAG_core__BitVectorNs_O" :stamp-key "core::BitVectorNs_O" :parent-class "core::template_Vector" :lisp-class-base "core::ComplexVector_O" :root-class "core::T_O" :stamp-wtag 3 @@ -2932,6 +3084,36 @@ :length-field-names ("_Dimensions" "._MaybeSignedLength") :end-field-names ("_Dimensions" "._MaybeSignedLength")} {variable-field-only :offset-type-cxx-identifier "ctype_unsigned_long" :fixup-type "unsigned long"} +{class-kind :stamp-name "STAMPWTAG_core__ComplexVector_short_float_O" + :stamp-key "core::ComplexVector_short_float_O" + :parent-class "core::template_Vector" + :lisp-class-base "core::ComplexVector_O" :root-class "core::T_O" :stamp-wtag 3 + :definition-data "IS_POLYMORPHIC"} +{fixed-field :offset-type-cxx-identifier "CONSTANT_ARRAY_OFFSET" :offset-ctype "UnknownType" + :offset-base-ctype "core::ComplexVector_short_float_O" + :layout-offset-field-names ("_Length")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::ComplexVector_short_float_O" + :layout-offset-field-names ("_FillPointerOrLengthOrDummy")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::ComplexVector_short_float_O" + :layout-offset-field-names ("_ArrayTotalSize")} +{fixed-field :offset-type-cxx-identifier "SMART_PTR_OFFSET" + :offset-ctype "gctools::smart_ptr" + :offset-base-ctype "core::ComplexVector_short_float_O" + :layout-offset-field-names ("_Data")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::ComplexVector_short_float_O" + :layout-offset-field-names ("_DisplacedIndexOffset")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::ComplexVector_short_float_O" + :layout-offset-field-names ("_Flags" "._Flags")} +{variable-array0 :offset-base-ctype "core::ComplexVector_short_float_O" + :field-names ("_Dimensions" "._Data")} +{variable-capacity :ctype "unsigned long" :offset-base-ctype "core::ComplexVector_short_float_O" + :length-field-names ("_Dimensions" "._MaybeSignedLength") + :end-field-names ("_Dimensions" "._MaybeSignedLength")} +{variable-field-only :offset-type-cxx-identifier "ctype_unsigned_long" :fixup-type "unsigned long"} {class-kind :stamp-name "STAMPWTAG_core__ComplexVector_int64_t_O" :stamp-key "core::ComplexVector_int64_t_O" :parent-class "core::template_Vector" @@ -2969,6 +3151,20 @@ {fixed-field :offset-type-cxx-identifier "CONSTANT_ARRAY_OFFSET" :offset-ctype "UnknownType" :offset-base-ctype "core::AbstractSimpleVector_O" :layout-offset-field-names ("_Length")} +{class-kind :stamp-name "STAMPWTAG_core__SimpleVector_long_float_O" + :stamp-key "core::SimpleVector_long_float_O" + :parent-class "core::template_SimpleVector" + :lisp-class-base "core::AbstractSimpleVector_O" :root-class "core::T_O" :stamp-wtag 3 + :definition-data "IS_POLYMORPHIC"} +{fixed-field :offset-type-cxx-identifier "CONSTANT_ARRAY_OFFSET" :offset-ctype "UnknownType" + :offset-base-ctype "core::SimpleVector_long_float_O" + :layout-offset-field-names ("_Length")} +{variable-array0 :offset-base-ctype "core::SimpleVector_long_float_O" + :field-names ("_Data" "._Data")} +{variable-capacity :ctype "long double" :offset-base-ctype "core::SimpleVector_long_float_O" + :length-field-names ("_Data" "._MaybeSignedLength") + :end-field-names ("_Data" "._MaybeSignedLength")} +{variable-field-only :offset-type-cxx-identifier "ctype_long_double" :fixup-type "long double"} {class-kind :stamp-name "STAMPWTAG_core__SimpleString_O" :stamp-key "core::SimpleString_O" :parent-class "core::AbstractSimpleVector_O" :lisp-class-base "core::AbstractSimpleVector_O" :root-class "core::T_O" :stamp-wtag 3 @@ -3230,6 +3426,20 @@ {variable-capacity :ctype "unsigned long" :offset-base-ctype "core::SimpleVector_byte4_t_O" :length-field-names ("_Data" "._Length") :end-field-names ("_Data" "._Length")} {variable-field-only :offset-type-cxx-identifier "ctype_unsigned_long" :fixup-type "unsigned long"} +{class-kind :stamp-name "STAMPWTAG_core__SimpleVector_short_float_O" + :stamp-key "core::SimpleVector_short_float_O" + :parent-class "core::template_SimpleVector" + :lisp-class-base "core::AbstractSimpleVector_O" :root-class "core::T_O" :stamp-wtag 3 + :definition-data "IS_POLYMORPHIC"} +{fixed-field :offset-type-cxx-identifier "CONSTANT_ARRAY_OFFSET" :offset-ctype "UnknownType" + :offset-base-ctype "core::SimpleVector_short_float_O" + :layout-offset-field-names ("_Length")} +{variable-array0 :offset-base-ctype "core::SimpleVector_short_float_O" + :field-names ("_Data" "._Data")} +{variable-capacity :ctype "float" :offset-base-ctype "core::SimpleVector_short_float_O" + :length-field-names ("_Data" "._MaybeSignedLength") + :end-field-names ("_Data" "._MaybeSignedLength")} +{variable-field-only :offset-type-cxx-identifier "ctype_float" :fixup-type "float"} {class-kind :stamp-name "STAMPWTAG_core__Symbol_O" :stamp-key "core::Symbol_O" :parent-class "core::General_O" :lisp-class-base "core::General_O" :root-class "core::T_O" :stamp-wtag 3 :definition-data "IS_POLYMORPHIC"} @@ -4923,11 +5133,11 @@ {class-kind :stamp-name "STAMPWTAG_core__LongFloat_O" :stamp-key "core::LongFloat_O" :parent-class "core::Float_O" :lisp-class-base "core::Float_O" :root-class "core::T_O" :stamp-wtag 3 :definition-data "IS_POLYMORPHIC"} +{fixed-field :offset-type-cxx-identifier "ctype_long_double" :offset-ctype "long double" + :offset-base-ctype "core::LongFloat_O" :layout-offset-field-names ("_Value")} {class-kind :stamp-name "STAMPWTAG_core__ShortFloat_O" :stamp-key "core::ShortFloat_O" :parent-class "core::Float_O" :lisp-class-base "core::Float_O" :root-class "core::T_O" :stamp-wtag 3 :definition-data "IS_POLYMORPHIC"} -{fixed-field :offset-type-cxx-identifier "ctype_float" :offset-ctype "float" - :offset-base-ctype "core::ShortFloat_O" :layout-offset-field-names ("_Value")} {class-kind :stamp-name "STAMPWTAG_core__Complex_O" :stamp-key "core::Complex_O" :parent-class "core::Number_O" :lisp-class-base "core::Number_O" :root-class "core::T_O" :stamp-wtag 3 :definition-data "IS_POLYMORPHIC"} @@ -6306,6 +6516,15 @@ :length-field-names ("_Capacity") :end-field-names ("_End")} {variable-field-only :offset-type-cxx-identifier "SMART_PTR_OFFSET" :fixup-type "gctools::smart_ptr"} +{container-kind :stamp-name "STAMPWTAG_gctools__GCArray_moveable_long_double_" + :stamp-key "gctools::GCArray_moveable" + :parent-class "gctools::GCContainer" :lisp-class-base nil + :root-class "gctools::GCContainer" :stamp-wtag 3 :definition-data "0"} +{variable-array0 :offset-base-ctype "gctools::GCArray_moveable" :field-names ("_Data")} +{variable-capacity :ctype "long double" :offset-base-ctype "gctools::GCArray_moveable" + :length-field-names ("_MaybeSignedLength") + :end-field-names ("_MaybeSignedLength")} +{variable-field-only :offset-type-cxx-identifier "ctype_long_double" :fixup-type "long double"} {container-kind :stamp-name "STAMPWTAG_gctools__GCVector_moveable_core__T_O___" :stamp-key "gctools::GCVector_moveable" :parent-class "gctools::GCContainer" :lisp-class-base nil diff --git a/src/analysis/clasp_gc_cando.sif b/src/analysis/clasp_gc_cando.sif index f307fce0de..562c543527 100644 --- a/src/analysis/clasp_gc_cando.sif +++ b/src/analysis/clasp_gc_cando.sif @@ -37,10 +37,10 @@ "core::SimpleVector_byte4_t_O" "llvmo::UndefValue_O" "chem::EstimateStretch" "llvmo::CallBase_O" "chem::ChemInfoNode_O" "core::Path_O" "mp::SharedMutex_O" "chem::BoundingBox_O" - "adapt::QDomNode_O" "chem::StructureComparer_O" - "asttooling::DerivableASTFrontendAction" "core::InstanceCreator_O" - "core::Scope_O" "chem::BondLogical_O" "chem::MoleculeGraph_O" - "chem::BondToAtomTest_O" "chem::FFAngleDb_O" + "core::ComplexVector_long_float_O" "adapt::QDomNode_O" + "chem::StructureComparer_O" "asttooling::DerivableASTFrontendAction" + "core::InstanceCreator_O" "core::Scope_O" "chem::BondLogical_O" + "chem::MoleculeGraph_O" "chem::BondToAtomTest_O" "chem::FFAngleDb_O" "core::BytecodeDebugLocation_O" "chem::FFTypeRule_O" "llvmo::InsertPoint_O" "core::FunctionDescription_O" "core::ComplexVector_double_O" "core::StrWNs_O" @@ -89,11 +89,12 @@ "core::StrNs_O" "comp::GlobalFunInfo_O" "clasp_ffi::ForeignData_O" "llvmo::CallInst_O" "chem::VirtualAtom_O" "core::BytecodeAstDecls_O" "chem::AfterMatchBondToAtomTest_O" "core::DoubleFloat_O" - "adapt::AdaptExposer_O" "core::DebuggerFrame_O" - "chem::ConformationExplorerEntryStage_O" "comp::LocalMacroInfo_O" - "chem::FrameRecognizer_O" "chem::CalculatePositionAlongBond_O" - "comp::LexFixup_O" "core::StringStream_O" "llvmo::LibraryBase_O" - "core::Sigset_O" "core::MDArray_int32_t_O" "adapt::SymbolList_O" + "core::ComplexVector_short_float_O" "core::DebuggerFrame_O" + "chem::ConformationExplorerEntryStage_O" "adapt::AdaptExposer_O" + "comp::LocalMacroInfo_O" "chem::FrameRecognizer_O" + "chem::CalculatePositionAlongBond_O" "comp::LexFixup_O" + "core::StringStream_O" "llvmo::LibraryBase_O" "core::Sigset_O" + "core::MDArray_int32_t_O" "adapt::SymbolList_O" "chem::CalculatePositionUsingInternals_O" "chem::EnergyPeriodicBoundaryConditionsNonbond_O" "asttooling::AsttoolingExposer_O" "chem::HybridizationInfo" @@ -108,7 +109,8 @@ "chem::EnergyAnchorRestraint" "core::MDArray_int4_t_O" "core::WeakKeyHashTable_O" "chem::FFNonbondCrossTerm" "core::Rack_O" "core::MDArrayBaseChar_O" "core::UserData_O" "core::ExternalObject_O" - "llvmo::DINode_O" "llvmo::GlobalVariable_O" "core::BroadcastStream_O" + "llvmo::DINode_O" "llvmo::GlobalVariable_O" + "core::SimpleVector_short_float_O" "core::BroadcastStream_O" "chem::FFBaseDb_O" "chem::AbstractLargeSquareMatrix_O" "core::General_O" "core::BytecodeSimpleFun_O" "llvmo::MemoryBuffer_O" "llvmo::ObjectFile_O" "chem::ConformationExplorerMatch_O" "llvmo::Library_O" "core::Closure_O" @@ -181,18 +183,21 @@ "llvmo::IRBuilderBase_O" "units::Unit_O" "core::Null_O" "chem::RingFinder_O" "chem::IterateBonds_O" "core::RequiredArgument" "core::SingleDispatchMethod_O" "chem::CDFragment_O" "comp::VarInfo_O" - "core::CxxObject_O" "llvmo::ReturnInst_O" "llvmo::FunctionType_O" - "clbind::DummyCreator_O" "chem::EnergyDihedralRestraint" - "core::MDArray_byte16_t_O" "llvmo::DIContext_O" - "chem::FFNonbondCrossTermTable_O" "llvmo::JITDylib_O" "llvmo::Type_O" - "chem::Command_O" "core::Pointer_O" "llvmo::UnreachableInst_O" - "core::ComplexVector_int64_t_O" "chem::FFParameterBaseDb_O" - "core::FileScope_O" "core::SimpleMDArray_byte4_t_O" "core::Float_O" + "core::CxxObject_O" "core::SimpleVector_long_float_O" + "llvmo::ReturnInst_O" "llvmo::FunctionType_O" "clbind::DummyCreator_O" + "chem::EnergyDihedralRestraint" "core::MDArray_byte16_t_O" + "llvmo::DIContext_O" "chem::FFNonbondCrossTermTable_O" + "llvmo::JITDylib_O" "llvmo::Type_O" "chem::Command_O" "core::Pointer_O" + "llvmo::UnreachableInst_O" "core::ComplexVector_int64_t_O" + "core::SimpleMDArray_short_float_O" "chem::FFParameterBaseDb_O" + "core::SimpleMDArray_long_float_O" "core::FileScope_O" + "core::SimpleMDArray_byte4_t_O" "core::Float_O" "chem::EnergySketchStretch" "chem::ResidueTest_O" "chem::RestraintDistance_O" "llvmo::DIDerivedType_O" "chem::SmartsRoot_O" "chem::TwisterDriver_O" "comp::EntryCloseFixup_O" "core::SimpleVector_int64_t_O" "llvmo::ConstantDataSequential_O" "chem::SuperposeEngine_O" "comp::EntryFixup_O" + "core::MDArray_short_float_O" "chem::BeyondThresholdFixedNonbondRestraint" "units::NamedUnit_O" "core::MDArray_double_O" "llvmo::StoreInst_O" "llvmo::DebugLoc_O" "chem::ResidueList_O" "core::WeakPointer_O" "core::DestDynEnv_O" @@ -231,8 +236,9 @@ "core::SynonymStream_O" "core::Ratio_O" "core::BytecodeModule_O" "core::MDArray_int2_t_O" "core::ComplexVector_byte2_t_O" "chem::FixedNonbondRestraint" "llvmo::ExecutionEngine_O" - "core::ClassRepCreator_O" "core::SimpleVector_int16_t_O" - "llvmo::Attribute_O" "core::DerivableCxxObject_O" "llvmo::SwitchInst_O" + "core::ClassRepCreator_O" "core::MDArray_long_float_O" + "core::SimpleVector_int16_t_O" "llvmo::Attribute_O" + "core::DerivableCxxObject_O" "llvmo::SwitchInst_O" "core::SymbolToEnumConverter_O" "chem::RestrainedPiBond_O" "chem::ConformationCollection_O" "core::SingleDispatchGenericFunction_O" "core::ComplexVector_int32_t_O" "chem::StepReport_O" "geom::Color_O" @@ -6094,11 +6100,11 @@ {class-kind :stamp-name "STAMPWTAG_core__LongFloat_O" :stamp-key "core::LongFloat_O" :parent-class "core::Float_O" :lisp-class-base "core::Float_O" :root-class "core::T_O" :stamp-wtag 3 :definition-data "IS_POLYMORPHIC"} +{fixed-field :offset-type-cxx-identifier "ctype_long_double" :offset-ctype "long double" + :offset-base-ctype "core::LongFloat_O" :layout-offset-field-names ("_Value")} {class-kind :stamp-name "STAMPWTAG_core__ShortFloat_O" :stamp-key "core::ShortFloat_O" :parent-class "core::Float_O" :lisp-class-base "core::Float_O" :root-class "core::T_O" :stamp-wtag 3 :definition-data "IS_POLYMORPHIC"} -{fixed-field :offset-type-cxx-identifier "ctype_float" :offset-ctype "float" - :offset-base-ctype "core::ShortFloat_O" :layout-offset-field-names ("_Value")} {class-kind :stamp-name "STAMPWTAG_core__Complex_O" :stamp-key "core::Complex_O" :parent-class "core::Number_O" :lisp-class-base "core::Number_O" :root-class "core::T_O" :stamp-wtag 3 :definition-data "IS_POLYMORPHIC"} @@ -7139,6 +7145,36 @@ :length-field-names ("_Dimensions" "._MaybeSignedLength") :end-field-names ("_Dimensions" "._MaybeSignedLength")} {variable-field-only :offset-type-cxx-identifier "ctype_unsigned_long" :fixup-type "unsigned long"} +{class-kind :stamp-name "STAMPWTAG_core__SimpleMDArray_long_float_O" + :stamp-key "core::SimpleMDArray_long_float_O" + :parent-class "core::template_SimpleArray" + :lisp-class-base "core::SimpleMDArray_O" :root-class "core::T_O" :stamp-wtag 3 + :definition-data "IS_POLYMORPHIC"} +{fixed-field :offset-type-cxx-identifier "CONSTANT_ARRAY_OFFSET" :offset-ctype "UnknownType" + :offset-base-ctype "core::SimpleMDArray_long_float_O" + :layout-offset-field-names ("_Length")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::SimpleMDArray_long_float_O" + :layout-offset-field-names ("_FillPointerOrLengthOrDummy")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::SimpleMDArray_long_float_O" + :layout-offset-field-names ("_ArrayTotalSize")} +{fixed-field :offset-type-cxx-identifier "SMART_PTR_OFFSET" + :offset-ctype "gctools::smart_ptr" + :offset-base-ctype "core::SimpleMDArray_long_float_O" + :layout-offset-field-names ("_Data")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::SimpleMDArray_long_float_O" + :layout-offset-field-names ("_DisplacedIndexOffset")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::SimpleMDArray_long_float_O" + :layout-offset-field-names ("_Flags" "._Flags")} +{variable-array0 :offset-base-ctype "core::SimpleMDArray_long_float_O" + :field-names ("_Dimensions" "._Data")} +{variable-capacity :ctype "unsigned long" :offset-base-ctype "core::SimpleMDArray_long_float_O" + :length-field-names ("_Dimensions" "._MaybeSignedLength") + :end-field-names ("_Dimensions" "._MaybeSignedLength")} +{variable-field-only :offset-type-cxx-identifier "ctype_unsigned_long" :fixup-type "unsigned long"} {class-kind :stamp-name "STAMPWTAG_core__SimpleMDArrayCharacter_O" :stamp-key "core::SimpleMDArrayCharacter_O" :parent-class "core::template_SimpleArray" @@ -7289,6 +7325,36 @@ :length-field-names ("_Dimensions" "._MaybeSignedLength") :end-field-names ("_Dimensions" "._MaybeSignedLength")} {variable-field-only :offset-type-cxx-identifier "ctype_unsigned_long" :fixup-type "unsigned long"} +{class-kind :stamp-name "STAMPWTAG_core__SimpleMDArray_short_float_O" + :stamp-key "core::SimpleMDArray_short_float_O" + :parent-class "core::template_SimpleArray" + :lisp-class-base "core::SimpleMDArray_O" :root-class "core::T_O" :stamp-wtag 3 + :definition-data "IS_POLYMORPHIC"} +{fixed-field :offset-type-cxx-identifier "CONSTANT_ARRAY_OFFSET" :offset-ctype "UnknownType" + :offset-base-ctype "core::SimpleMDArray_short_float_O" + :layout-offset-field-names ("_Length")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::SimpleMDArray_short_float_O" + :layout-offset-field-names ("_FillPointerOrLengthOrDummy")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::SimpleMDArray_short_float_O" + :layout-offset-field-names ("_ArrayTotalSize")} +{fixed-field :offset-type-cxx-identifier "SMART_PTR_OFFSET" + :offset-ctype "gctools::smart_ptr" + :offset-base-ctype "core::SimpleMDArray_short_float_O" + :layout-offset-field-names ("_Data")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::SimpleMDArray_short_float_O" + :layout-offset-field-names ("_DisplacedIndexOffset")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::SimpleMDArray_short_float_O" + :layout-offset-field-names ("_Flags" "._Flags")} +{variable-array0 :offset-base-ctype "core::SimpleMDArray_short_float_O" + :field-names ("_Dimensions" "._Data")} +{variable-capacity :ctype "unsigned long" :offset-base-ctype "core::SimpleMDArray_short_float_O" + :length-field-names ("_Dimensions" "._MaybeSignedLength") + :end-field-names ("_Dimensions" "._MaybeSignedLength")} +{variable-field-only :offset-type-cxx-identifier "ctype_unsigned_long" :fixup-type "unsigned long"} {class-kind :stamp-name "STAMPWTAG_core__SimpleMDArray_double_O" :stamp-key "core::SimpleMDArray_double_O" :parent-class "core::template_SimpleArray" @@ -7688,6 +7754,36 @@ :length-field-names ("_Dimensions" "._MaybeSignedLength") :end-field-names ("_Dimensions" "._MaybeSignedLength")} {variable-field-only :offset-type-cxx-identifier "ctype_unsigned_long" :fixup-type "unsigned long"} +{class-kind :stamp-name "STAMPWTAG_core__ComplexVector_long_float_O" + :stamp-key "core::ComplexVector_long_float_O" + :parent-class "core::template_Vector" + :lisp-class-base "core::ComplexVector_O" :root-class "core::T_O" :stamp-wtag 3 + :definition-data "IS_POLYMORPHIC"} +{fixed-field :offset-type-cxx-identifier "CONSTANT_ARRAY_OFFSET" :offset-ctype "UnknownType" + :offset-base-ctype "core::ComplexVector_long_float_O" + :layout-offset-field-names ("_Length")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::ComplexVector_long_float_O" + :layout-offset-field-names ("_FillPointerOrLengthOrDummy")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::ComplexVector_long_float_O" + :layout-offset-field-names ("_ArrayTotalSize")} +{fixed-field :offset-type-cxx-identifier "SMART_PTR_OFFSET" + :offset-ctype "gctools::smart_ptr" + :offset-base-ctype "core::ComplexVector_long_float_O" + :layout-offset-field-names ("_Data")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::ComplexVector_long_float_O" + :layout-offset-field-names ("_DisplacedIndexOffset")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::ComplexVector_long_float_O" + :layout-offset-field-names ("_Flags" "._Flags")} +{variable-array0 :offset-base-ctype "core::ComplexVector_long_float_O" + :field-names ("_Dimensions" "._Data")} +{variable-capacity :ctype "unsigned long" :offset-base-ctype "core::ComplexVector_long_float_O" + :length-field-names ("_Dimensions" "._MaybeSignedLength") + :end-field-names ("_Dimensions" "._MaybeSignedLength")} +{variable-field-only :offset-type-cxx-identifier "ctype_unsigned_long" :fixup-type "unsigned long"} {class-kind :stamp-name "STAMPWTAG_geom__ComplexVectorCoordinate_O" :stamp-key "geom::ComplexVectorCoordinate_O" :parent-class "core::template_Vector" @@ -8140,6 +8236,36 @@ :length-field-names ("_Dimensions" "._MaybeSignedLength") :end-field-names ("_Dimensions" "._MaybeSignedLength")} {variable-field-only :offset-type-cxx-identifier "ctype_unsigned_long" :fixup-type "unsigned long"} +{class-kind :stamp-name "STAMPWTAG_core__ComplexVector_short_float_O" + :stamp-key "core::ComplexVector_short_float_O" + :parent-class "core::template_Vector" + :lisp-class-base "core::ComplexVector_O" :root-class "core::T_O" :stamp-wtag 3 + :definition-data "IS_POLYMORPHIC"} +{fixed-field :offset-type-cxx-identifier "CONSTANT_ARRAY_OFFSET" :offset-ctype "UnknownType" + :offset-base-ctype "core::ComplexVector_short_float_O" + :layout-offset-field-names ("_Length")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::ComplexVector_short_float_O" + :layout-offset-field-names ("_FillPointerOrLengthOrDummy")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::ComplexVector_short_float_O" + :layout-offset-field-names ("_ArrayTotalSize")} +{fixed-field :offset-type-cxx-identifier "SMART_PTR_OFFSET" + :offset-ctype "gctools::smart_ptr" + :offset-base-ctype "core::ComplexVector_short_float_O" + :layout-offset-field-names ("_Data")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::ComplexVector_short_float_O" + :layout-offset-field-names ("_DisplacedIndexOffset")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::ComplexVector_short_float_O" + :layout-offset-field-names ("_Flags" "._Flags")} +{variable-array0 :offset-base-ctype "core::ComplexVector_short_float_O" + :field-names ("_Dimensions" "._Data")} +{variable-capacity :ctype "unsigned long" :offset-base-ctype "core::ComplexVector_short_float_O" + :length-field-names ("_Dimensions" "._MaybeSignedLength") + :end-field-names ("_Dimensions" "._MaybeSignedLength")} +{variable-field-only :offset-type-cxx-identifier "ctype_unsigned_long" :fixup-type "unsigned long"} {class-kind :stamp-name "STAMPWTAG_core__ComplexVector_int64_t_O" :stamp-key "core::ComplexVector_int64_t_O" :parent-class "core::template_Vector" @@ -8170,6 +8296,63 @@ :length-field-names ("_Dimensions" "._MaybeSignedLength") :end-field-names ("_Dimensions" "._MaybeSignedLength")} {variable-field-only :offset-type-cxx-identifier "ctype_unsigned_long" :fixup-type "unsigned long"} +{class-kind :stamp-name "STAMPWTAG_core__MDArray_short_float_O" + :stamp-key "core::MDArray_short_float_O" + :parent-class "core::template_Array" + :lisp-class-base "core::MDArray_O" :root-class "core::T_O" :stamp-wtag 3 + :definition-data "IS_POLYMORPHIC"} +{fixed-field :offset-type-cxx-identifier "CONSTANT_ARRAY_OFFSET" :offset-ctype "UnknownType" + :offset-base-ctype "core::MDArray_short_float_O" + :layout-offset-field-names ("_Length")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::MDArray_short_float_O" + :layout-offset-field-names ("_FillPointerOrLengthOrDummy")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::MDArray_short_float_O" + :layout-offset-field-names ("_ArrayTotalSize")} +{fixed-field :offset-type-cxx-identifier "SMART_PTR_OFFSET" + :offset-ctype "gctools::smart_ptr" + :offset-base-ctype "core::MDArray_short_float_O" :layout-offset-field-names ("_Data")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::MDArray_short_float_O" + :layout-offset-field-names ("_DisplacedIndexOffset")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::MDArray_short_float_O" + :layout-offset-field-names ("_Flags" "._Flags")} +{variable-array0 :offset-base-ctype "core::MDArray_short_float_O" + :field-names ("_Dimensions" "._Data")} +{variable-capacity :ctype "unsigned long" :offset-base-ctype "core::MDArray_short_float_O" + :length-field-names ("_Dimensions" "._MaybeSignedLength") + :end-field-names ("_Dimensions" "._MaybeSignedLength")} +{variable-field-only :offset-type-cxx-identifier "ctype_unsigned_long" :fixup-type "unsigned long"} +{class-kind :stamp-name "STAMPWTAG_core__MDArray_long_float_O" + :stamp-key "core::MDArray_long_float_O" + :parent-class "core::template_Array" + :lisp-class-base "core::MDArray_O" :root-class "core::T_O" :stamp-wtag 3 + :definition-data "IS_POLYMORPHIC"} +{fixed-field :offset-type-cxx-identifier "CONSTANT_ARRAY_OFFSET" :offset-ctype "UnknownType" + :offset-base-ctype "core::MDArray_long_float_O" :layout-offset-field-names ("_Length")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::MDArray_long_float_O" + :layout-offset-field-names ("_FillPointerOrLengthOrDummy")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::MDArray_long_float_O" + :layout-offset-field-names ("_ArrayTotalSize")} +{fixed-field :offset-type-cxx-identifier "SMART_PTR_OFFSET" + :offset-ctype "gctools::smart_ptr" + :offset-base-ctype "core::MDArray_long_float_O" :layout-offset-field-names ("_Data")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::MDArray_long_float_O" + :layout-offset-field-names ("_DisplacedIndexOffset")} +{fixed-field :offset-type-cxx-identifier "ctype_unsigned_long" :offset-ctype "unsigned long" + :offset-base-ctype "core::MDArray_long_float_O" + :layout-offset-field-names ("_Flags" "._Flags")} +{variable-array0 :offset-base-ctype "core::MDArray_long_float_O" + :field-names ("_Dimensions" "._Data")} +{variable-capacity :ctype "unsigned long" :offset-base-ctype "core::MDArray_long_float_O" + :length-field-names ("_Dimensions" "._MaybeSignedLength") + :end-field-names ("_Dimensions" "._MaybeSignedLength")} +{variable-field-only :offset-type-cxx-identifier "ctype_unsigned_long" :fixup-type "unsigned long"} {class-kind :stamp-name "STAMPWTAG_core__MDArray_int64_t_O" :stamp-key "core::MDArray_int64_t_O" :parent-class "core::template_Array" :lisp-class-base "core::MDArray_O" :root-class "core::T_O" :stamp-wtag 3 @@ -8387,6 +8570,20 @@ {fixed-field :offset-type-cxx-identifier "CONSTANT_ARRAY_OFFSET" :offset-ctype "UnknownType" :offset-base-ctype "core::AbstractSimpleVector_O" :layout-offset-field-names ("_Length")} +{class-kind :stamp-name "STAMPWTAG_core__SimpleVector_long_float_O" + :stamp-key "core::SimpleVector_long_float_O" + :parent-class "core::template_SimpleVector" + :lisp-class-base "core::AbstractSimpleVector_O" :root-class "core::T_O" :stamp-wtag 3 + :definition-data "IS_POLYMORPHIC"} +{fixed-field :offset-type-cxx-identifier "CONSTANT_ARRAY_OFFSET" :offset-ctype "UnknownType" + :offset-base-ctype "core::SimpleVector_long_float_O" + :layout-offset-field-names ("_Length")} +{variable-array0 :offset-base-ctype "core::SimpleVector_long_float_O" + :field-names ("_Data" "._Data")} +{variable-capacity :ctype "long double" :offset-base-ctype "core::SimpleVector_long_float_O" + :length-field-names ("_Data" "._MaybeSignedLength") + :end-field-names ("_Data" "._MaybeSignedLength")} +{variable-field-only :offset-type-cxx-identifier "ctype_long_double" :fixup-type "long double"} {class-kind :stamp-name "STAMPWTAG_core__SimpleVector_byte32_t_O" :stamp-key "core::SimpleVector_byte32_t_O" :parent-class "core::template_SimpleVector" @@ -8491,6 +8688,20 @@ {variable-capacity :ctype "Vector3" :offset-base-ctype "geom::SimpleVectorCoordinate_O" :length-field-names ("_Data" "._MaybeSignedLength") :end-field-names ("_Data" "._MaybeSignedLength")} +{class-kind :stamp-name "STAMPWTAG_core__SimpleVector_short_float_O" + :stamp-key "core::SimpleVector_short_float_O" + :parent-class "core::template_SimpleVector" + :lisp-class-base "core::AbstractSimpleVector_O" :root-class "core::T_O" :stamp-wtag 3 + :definition-data "IS_POLYMORPHIC"} +{fixed-field :offset-type-cxx-identifier "CONSTANT_ARRAY_OFFSET" :offset-ctype "UnknownType" + :offset-base-ctype "core::SimpleVector_short_float_O" + :layout-offset-field-names ("_Length")} +{variable-array0 :offset-base-ctype "core::SimpleVector_short_float_O" + :field-names ("_Data" "._Data")} +{variable-capacity :ctype "float" :offset-base-ctype "core::SimpleVector_short_float_O" + :length-field-names ("_Data" "._MaybeSignedLength") + :end-field-names ("_Data" "._MaybeSignedLength")} +{variable-field-only :offset-type-cxx-identifier "ctype_float" :fixup-type "float"} {class-kind :stamp-name "STAMPWTAG_core__SimpleString_O" :stamp-key "core::SimpleString_O" :parent-class "core::AbstractSimpleVector_O" :lisp-class-base "core::AbstractSimpleVector_O" :root-class "core::T_O" :stamp-wtag 3 @@ -11141,6 +11352,15 @@ :length-field-names ("_Capacity") :end-field-names ("_End")} {variable-field-only :offset-type-cxx-identifier "SMART_PTR_OFFSET" :fixup-type "gctools::smart_ptr"} +{container-kind :stamp-name "STAMPWTAG_gctools__GCArray_moveable_long_double_" + :stamp-key "gctools::GCArray_moveable" + :parent-class "gctools::GCContainer" :lisp-class-base nil + :root-class "gctools::GCContainer" :stamp-wtag 3 :definition-data "0"} +{variable-array0 :offset-base-ctype "gctools::GCArray_moveable" :field-names ("_Data")} +{variable-capacity :ctype "long double" :offset-base-ctype "gctools::GCArray_moveable" + :length-field-names ("_MaybeSignedLength") + :end-field-names ("_MaybeSignedLength")} +{variable-field-only :offset-type-cxx-identifier "ctype_long_double" :fixup-type "long double"} {container-kind :stamp-name "STAMPWTAG_gctools__GCVector_moveable_core__T_O___" :stamp-key "gctools::GCVector_moveable" :parent-class "gctools::GCContainer" :lisp-class-base nil diff --git a/src/core/array.cc b/src/core/array.cc index 0062faef0e..4ebdf4bb87 100644 --- a/src/core/array.cc +++ b/src/core/array.cc @@ -537,8 +537,6 @@ void core__copy_subarray(Array_sp dest, Fixnum_sp destStart, Array_sp orig, Fixn size_t iLen = unbox_fixnum(len); if (iLen == 0) return; - ASSERTF(dest->rank() == 1, "dest array must be rank 1 - instead it is {}", dest->rank()); - ASSERTF(orig->rank() == 1, "orig array must be rank 1 - instead it is {}", orig->rank()); size_t iDestStart = unbox_fixnum(destStart); size_t iOrigStart = unbox_fixnum(origStart); if ((iLen + iDestStart) >= dest->arrayTotalSize()) @@ -796,6 +794,16 @@ DEFMAKESIMPLEVECTOR(base_char, SimpleBaseString_O, SimpleBaseString_sp); DEFMAKESIMPLEVECTOR(character, SimpleCharacterString_O, SimpleCharacterString_sp); DEFMAKESIMPLEVECTOR(single_float, SimpleVector_float_O, SimpleVector_float_sp); DEFMAKESIMPLEVECTOR(double_float, SimpleVector_double_O, SimpleVector_double_sp); +#ifdef CLASP_SHORT_FLOAT +DEFMAKESIMPLEVECTOR(short_float, SimpleVector_short_float_O, SimpleVector_short_float_sp); +#else +DEFMAKESIMPLEVECTOR(short_float, SimpleVector_float_O, SimpleVector_float_sp); +#endif +#ifdef CLASP_LONG_FLOAT +DEFMAKESIMPLEVECTOR(long_float, SimpleVector_long_float_O, SimpleVector_long_float_sp); +#else +DEFMAKESIMPLEVECTOR(long_float, SimpleVector_double_O, SimpleVector_double_sp); +#endif DEFMAKESIMPLEVECTOR(int2, SimpleVector_int2_t_O, SimpleVector_int2_t_sp); DEFMAKESIMPLEVECTOR(byte2, SimpleVector_byte2_t_O, SimpleVector_byte2_t_sp); DEFMAKESIMPLEVECTOR(int4, SimpleVector_int4_t_O, SimpleVector_int4_t_sp); @@ -832,8 +840,18 @@ CL_DEFUN SimpleMDArrayT_sp core__make_simple_mdarray_t(List_sp dimensions, T_sp DEFMAKESIMPLEMDARRAY(bit, SimpleMDArrayBit_O, SimpleMDArrayBit_sp, SimpleBitVector_O); DEFMAKESIMPLEMDARRAY(base_char, SimpleMDArrayBaseChar_O, SimpleMDArrayBaseChar_sp, SimpleBaseString_O); DEFMAKESIMPLEMDARRAY(character, SimpleMDArrayCharacter_O, SimpleMDArrayCharacter_sp, SimpleCharacterString_O); +#ifdef CLASP_SHORT_FLOAT +DEFMAKESIMPLEMDARRAY(short_float, SimpleMDArray_short_float_O, SimpleMDArray_short_float_sp, SimpleVector_short_float_O); +#else +DEFMAKESIMPLEMDARRAY(short_float, SimpleMDArray_float_O, SimpleMDArray_float_sp, SimpleVector_float_O); +#endif DEFMAKESIMPLEMDARRAY(single_float, SimpleMDArray_float_O, SimpleMDArray_float_sp, SimpleVector_float_O); DEFMAKESIMPLEMDARRAY(double_float, SimpleMDArray_double_O, SimpleMDArray_double_sp, SimpleVector_double_O); +#ifdef CLASP_LONG_FLOAT +DEFMAKESIMPLEMDARRAY(long_float, SimpleMDArray_long_float_O, SimpleMDArray_long_float_sp, SimpleVector_long_float_O); +#else +DEFMAKESIMPLEMDARRAY(long_float, SimpleMDArray_double_O, SimpleMDArray_double_sp, SimpleVector_double_O); +#endif DEFMAKESIMPLEMDARRAY(int2, SimpleMDArray_int2_t_O, SimpleMDArray_int2_t_sp, SimpleVector_int2_t_O); DEFMAKESIMPLEMDARRAY(byte2, SimpleMDArray_byte2_t_O, SimpleMDArray_byte2_t_sp, SimpleVector_byte2_t_O); DEFMAKESIMPLEMDARRAY(int4, SimpleMDArray_int4_t_O, SimpleMDArray_int4_t_sp, SimpleVector_int4_t_O); @@ -877,6 +895,14 @@ CL_DEFUN Vector_sp core__make_vector(T_sp element_type, size_t dimension, bool a MAKE(SimpleCharacterString_O, StrWNs_O) } else if (element_type == cl::_sym_double_float) { MAKE(SimpleVector_double_O, ComplexVector_double_O) +#ifdef CLASP_SHORT_FLOAT + } else if (element_type == cl::_sym_short_float) { + MAKE(SimpleVector_short_float_O, ComplexVector_short_float_O) +#endif +#ifdef CLASP_LONG_FLOAT + } else if (element_type == cl::_sym_long_float) { + MAKE(SimpleVector_long_float_O, ComplexVector_long_float_O) +#endif } else if (element_type == cl::_sym_single_float) { MAKE(SimpleVector_float_O, ComplexVector_float_O) } else if (element_type == ext::_sym_integer2) { @@ -929,6 +955,14 @@ CL_DEFUN Vector_sp core__make_static_vector(T_sp element_type, size_t dimension, MAKE(SimpleCharacterString_O) } else if (element_type == cl::_sym_double_float) { MAKE(SimpleVector_double_O) +#ifdef CLASP_SHORT_FLOAT + } else if (element_type == cl::_sym_short_float) { + MAKE(SimpleVector_short_float_O) +#endif +#ifdef CLASP_LONG_FLOAT + } else if (element_type == cl::_sym_long_float) { + MAKE(SimpleVector_long_float_O) +#endif } else if (element_type == cl::_sym_single_float) { MAKE(SimpleVector_float_O) } else if (element_type == cl::_sym_bit) { @@ -986,6 +1020,14 @@ CL_DEFUN MDArray_sp core__make_mdarray(List_sp dimensions, T_sp element_type, bo MAKE(MDArrayT_O, SimpleVector_O) } else if (element_type == cl::_sym_double_float) { MAKE(MDArray_double_O, SimpleVector_double_O) +#ifdef CLASP_SHORT_FLOAT + } else if (element_type == cl::_sym_short_float) { + MAKE(MDArray_short_O, SimpleVector_short_float_O) +#endif +#ifdef CLASP_LONG_FLOAT + } else if (element_type == cl::_sym_long_float) { + MAKE(MDArray_long_float_O, SimpleVector_long_float_O) +#endif } else if (element_type == cl::_sym_single_float) { MAKE(MDArray_float_O, SimpleVector_float_O) } else if (element_type == cl::_sym_bit) { @@ -1217,6 +1259,50 @@ CL_DEFUN bool ext__array_no_nans_p(Array_sp array) { for (size_t ii = 0; ii < sa->length(); ii++) if (std::isnan((*sa)[ii])) return false; +#ifdef CLASP_SHORT_FLOAT + } else if (gc::IsA(array)) { + auto sa = gc::As_unsafe(array); + for (size_t ii = 0; ii < sa->length(); ii++) + if (std::isnan((*sa)[ii])) + return false; + } else if (gc::IsA(array)) { + auto sa = gc::As_unsafe(array); + for (size_t ii = 0; ii < sa->length(); ii++) + if (std::isnan((*sa)[ii])) + return false; + } else if (gc::IsA(array)) { + auto sa = gc::As_unsafe(array); + for (size_t ii = 0; ii < sa->length(); ii++) + if (std::isnan((*sa)[ii])) + return false; + } else if (gc::IsA(array)) { + auto sa = gc::As_unsafe(array); + for (size_t ii = 0; ii < sa->length(); ii++) + if (std::isnan((*sa)[ii])) + return false; +#endif +#ifdef CLASP_LONG_FLOAT + } else if (gc::IsA(array)) { + auto sa = gc::As_unsafe(array); + for (size_t ii = 0; ii < sa->length(); ii++) + if (std::isnan((*sa)[ii])) + return false; + } else if (gc::IsA(array)) { + auto sa = gc::As_unsafe(array); + for (size_t ii = 0; ii < sa->length(); ii++) + if (std::isnan((*sa)[ii])) + return false; + } else if (gc::IsA(array)) { + auto sa = gc::As_unsafe(array); + for (size_t ii = 0; ii < sa->length(); ii++) + if (std::isnan((*sa)[ii])) + return false; + } else if (gc::IsA(array)) { + auto sa = gc::As_unsafe(array); + for (size_t ii = 0; ii < sa->length(); ii++) + if (std::isnan((*sa)[ii])) + return false; +#endif } return true; } diff --git a/src/core/bignum.cc b/src/core/bignum.cc index b0cc494d64..70419d8d3a 100644 --- a/src/core/bignum.cc +++ b/src/core/bignum.cc @@ -234,8 +234,9 @@ CL_DEFUN string core__next_primitive_string(Bignum_sp num) { return ss.str(); } +CL_NAME(two-arg-*-bignum-fixnum) DOCGROUP(clasp); -CL_DEFUN Integer_sp core__next_fmul(Bignum_sp left, Fixnum right) { +CL_DEFUN Integer_sp Number_O::mul_bx(Bignum_sp left, Fixnum right) { if (right == 0) return clasp_make_fixnum(0); mp_size_t llen = left->length(); @@ -354,8 +355,9 @@ Integer_sp Bignum_O::shift_right(Fixnum shift) const { return this->asSmartPtr(); } +CL_NAME(two-arg-*-bignum-bignum) DOCGROUP(clasp); -CL_DEFUN Bignum_sp core__next_mul(Bignum_sp left, Bignum_sp right) { +CL_DEFUN Bignum_sp Number_O::mul_bb(Bignum_sp left, Bignum_sp right) { // NOTE: The mpz_ functions detect when left = right (analogously) and use // mpn_sqr instead. I don't _think_ this is required, given they're untouched anyway. mp_size_t llen = left->length(), rlen = right->length(); @@ -403,8 +405,9 @@ CL_DEFUN Bignum_sp core__mul_fixnums(Fixnum left, Fixnum right) { } DOCGROUP(clasp); -CL_DEFUN T_mv core__next_truncate(Bignum_sp dividend, Bignum_sp divisor) { - ASSERT(dividend != divisor); // "No overlap is permitted between arguments" +CL_DEFUN Number_mv core__next_truncate(Bignum_sp dividend, Bignum_sp divisor) { + if (dividend == divisor) + return Values(clasp_make_fixnum(1), clasp_make_fixnum(0)); mp_size_t dividend_length = dividend->length(); mp_size_t divisor_length = divisor->length(); mp_size_t dividend_size = std::abs(dividend_length); @@ -434,7 +437,7 @@ CL_DEFUN T_mv core__next_truncate(Bignum_sp dividend, Bignum_sp divisor) { // Truncating a fixnum by a bignum will always get you zero // so there's no function for that. DOCGROUP(clasp); -CL_DEFUN T_mv core__next_ftruncate(Bignum_sp dividend, Fixnum divisor) { +CL_DEFUN Number_mv core__next_ftruncate(Bignum_sp dividend, Fixnum divisor) { if (divisor == 0) ERROR_DIVISION_BY_ZERO(dividend, clasp_make_fixnum(divisor)); mp_limb_t positive_divisor = std::abs(divisor); @@ -749,13 +752,15 @@ Integer_sp next_add(const mp_limb_t* llimbs, mp_size_t llen, const mp_limb_t* rl return bignum_result(result_len, result_limbs); } +CL_NAME(two-arg-+-bignum-bignum) DOCGROUP(clasp); -CL_DEFUN Integer_sp core__next_add(Bignum_sp left, Bignum_sp right) { +CL_DEFUN Integer_sp Number_O::add_bb(Bignum_sp left, Bignum_sp right) { return next_add(left->limbs(), left->length(), right->limbs(), right->length()); } +CL_NAME(two-arg---bignum-bignum) DOCGROUP(clasp); -CL_DEFUN Integer_sp core__next_sub(Bignum_sp left, Bignum_sp right) { +CL_DEFUN Integer_sp Number_O::sub_bb(Bignum_sp left, Bignum_sp right) { return next_add(left->limbs(), left->length(), right->limbs(), -(right->length())); } @@ -787,13 +792,15 @@ Integer_sp next_fadd(const mp_limb_t* limbs, mp_size_t len, Fixnum right) { return bignum_result(result_len, result_limbs); } +CL_NAME(two-arg-+-bignum-fixnum) DOCGROUP(clasp); -CL_DEFUN Integer_sp core__next_fadd(Bignum_sp left, Fixnum right) { return next_fadd(left->limbs(), left->length(), right); } +CL_DEFUN Integer_sp Number_O::add_bx(Bignum_sp left, Fixnum right) { return next_fadd(left->limbs(), left->length(), right); } // bignum - fixnum is trivially bignum +-fixnum, but fixnum - bignum // is very slightly trickier +CL_NAME(two-arg---fixnum-bignum) DOCGROUP(clasp); -CL_DEFUN Integer_sp core__next_fsub(Fixnum left, Bignum_sp right) { return next_fadd(right->limbs(), -(right->length()), left); } +CL_DEFUN Integer_sp Number_O::sub_xb(Fixnum left, Bignum_sp right) { return next_fadd(right->limbs(), -(right->length()), left); } Number_sp Bignum_O::oneMinus_() const { return next_fadd(this->limbs(), this->length(), -1); } @@ -806,7 +813,7 @@ template Float limbs_to_float(mp_size_t len, const mp_limb_t* l .category = float_convert::category::finite, .significand = 0, .exponent = (size - 1) * limb_width, .sign = (len < 0) ? -1 : 1 }; - size_t shift = float_convert::significand_width + 1; + size_t shift = float_convert::traits::significand_width + 1; size_t width = std::bit_width(limbs[size - 1]); if (width >= shift) { @@ -824,14 +831,16 @@ template Float limbs_to_float(mp_size_t len, const mp_limb_t* l } } - return float_convert::from_quadruple(q); + return float_convert::quadruple_to_float(q); } -float Bignum_O::as_float_() const { return limbs_to_float(this->length(), this->limbs()); } +short_float_t Bignum_O::as_short_float_() const { return limbs_to_float(this->length(), this->limbs()); } -double Bignum_O::as_double_() const { return limbs_to_float(this->length(), this->limbs()); } +single_float_t Bignum_O::as_single_float_() const { return limbs_to_float(this->length(), this->limbs()); } -LongFloat Bignum_O::as_long_float_() const { return limbs_to_float(this->length(), this->limbs()); } +double_float_t Bignum_O::as_double_float_() const { return limbs_to_float(this->length(), this->limbs()); } + +long_float_t Bignum_O::as_long_float_() const { return limbs_to_float(this->length(), this->limbs()); } DOCGROUP(clasp); CL_DEFUN int core__next_compare(Bignum_sp left, Bignum_sp right) { diff --git a/src/core/bits.cc b/src/core/bits.cc index ca2ecf5364..b97c82141e 100644 --- a/src/core/bits.cc +++ b/src/core/bits.cc @@ -731,11 +731,11 @@ CL_DEFUN bool cl__logbitp(Integer_sp index, Integer_sp i) { return (len < 0); } } else { - if (clasp_minusp(index)) + if (Real_O::minusp(index)) goto NEGINDEX; // Index is a bignum. // We don't support bignums with that many bits, so we're out of range. - if (clasp_minusp(i)) + if (Real_O::minusp(i)) return true; else return false; diff --git a/src/core/bytecode.cc b/src/core/bytecode.cc index 2c2d622ce0..ca6285a58e 100644 --- a/src/core/bytecode.cc +++ b/src/core/bytecode.cc @@ -227,15 +227,15 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure VM_RECORD_PLAYBACK(vm._stackPointer, "stackPointer"); } #endif - switch (*pc) { - case vm_ref: { + switch ((vm_code)*pc) { + case vm_code::ref: { uint8_t n = *(++pc); DBG_VM1("ref %" PRIu8 "\n", n); vm.push(sp, *(vm.reg(fp, n))); pc++; break; } - case vm_const: { + case vm_code::_const: { uint8_t n = *(++pc); DBG_VM1("const %" PRIu8 "\n", n); T_O* value = literals[n]; @@ -244,14 +244,14 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure pc++; break; } - case vm_closure: { + case vm_code::closure: { uint8_t n = *(++pc); DBG_VM("closure %" PRIu8 "\n", n); vm.push(sp, closed[n]); pc++; break; } - case vm_call: { + case vm_code::call: { uint8_t nargs = *(++pc); DBG_VM1("call %" PRIu8 "\n", nargs); T_sp tfunc((gctools::Tagged)(*(vm.stackref(sp, nargs)))); @@ -266,7 +266,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure pc++; break; } - case vm_call_receive_one: { + case vm_code::call_receive_one: { uint8_t nargs = *(++pc); DBG_VM1("call-receive-one %" PRIu8 "\n", nargs); T_sp tfunc((gctools::Tagged)(*(vm.stackref(sp, nargs)))); @@ -291,7 +291,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure pc++; break; } - case vm_call_receive_fixed: { + case vm_code::call_receive_fixed: { uint8_t nargs = *(++pc); uint8_t nvals = *(++pc); DBG_VM("call-receive-fixed %" PRIu8 " %" PRIu8 "\n", nargs, nvals); @@ -312,7 +312,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure pc++; break; } - case vm_bind: { + case vm_code::bind: { uint8_t nelems = *(++pc); uint8_t base = *(++pc); DBG_VM1("bind %" PRIu8 " %" PRIu8 "\n", nelems, base); @@ -321,14 +321,14 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure pc++; break; } - case vm_set: { + case vm_code::set: { uint8_t n = *(++pc); DBG_VM("set %" PRIu8 "\n", n); vm.setreg(fp, n, vm.pop(sp)); pc++; break; } - case vm_make_cell: { + case vm_code::make_cell: { DBG_VM1("make-cell\n"); T_sp car((gctools::Tagged)(vm.pop(sp))); T_sp cdr((gctools::Tagged)nil().raw_()); @@ -336,14 +336,14 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure pc++; break; } - case vm_cell_ref: { + case vm_code::cell_ref: { DBG_VM1("cell-ref\n"); T_sp cons((gctools::Tagged)vm.pop(sp)); vm.push(sp, cons.unsafe_cons()->car().raw_()); pc++; break; } - case vm_cell_set: { + case vm_code::cell_set: { DBG_VM("cell-set\n"); T_sp cons((gctools::Tagged)vm.pop(sp)); Cons_sp ccons = gc::As_assert(cons); @@ -353,7 +353,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure pc++; break; } - case vm_make_closure: { + case vm_code::make_closure: { uint8_t c = *(++pc); DBG_VM("make-closure %" PRIu8 "\n", c); T_sp fn_sp((gctools::Tagged)literals[c]); @@ -368,7 +368,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure pc++; break; } - case vm_make_uninitialized_closure: { + case vm_code::make_uninitialized_closure: { uint8_t c = *(++pc); DBG_VM("make-uninitialized-closure %" PRIu8 "\n", c); T_sp fn_sp((gctools::Tagged)literals[c]); @@ -380,7 +380,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure pc++; break; } - case vm_initialize_closure: { + case vm_code::initialize_closure: { uint8_t c = *(++pc); DBG_VM("initialize-closure %" PRIu8 "\n", c); T_sp tclosure((gctools::Tagged)(*(vm.reg(fp, c)))); @@ -395,21 +395,21 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure pc++; break; } - case vm_return: { + case vm_code::_return: { DBG_VM1("return\n"); // since the stack pointer is a local variable we don't need to // adjust it. size_t nvalues = multipleValues.getSize(); return gctools::return_type(multipleValues.valueGet(0, nvalues).raw_(), nvalues); } - case vm_bind_required_args: { + case vm_code::bind_required_args: { uint8_t nargs = *(++pc); DBG_VM("bind-required-args %" PRIu8 "\n", nargs); vm.copytoreg(fp, lcc_args, nargs, 0); pc++; break; } - case vm_bind_optional_args: { + case vm_code::bind_optional_args: { uint8_t nreq = *(++pc); uint8_t nopt = *(++pc); DBG_VM("bind-optional-args %" PRIu8 " %" PRIu8 "\n", nreq, nopt); @@ -424,7 +424,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure pc++; break; } - case vm_listify_rest_args: { + case vm_code::listify_rest_args: { uint8_t start = *(++pc); DBG_VM("listify-rest-args %" PRIu8 "\n", start); ql::list rest; @@ -436,7 +436,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure pc++; break; } - case vm_vaslistify_rest_args: { + case vm_code::vaslistify_rest_args: { // // This pushes two vaslist structures (each two words that look like fixnums) // onto the stack. the theVaslist_backup is used by vaslist_rewind @@ -448,7 +448,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure pc++; break; } - case vm_parse_key_args: { + case vm_code::parse_key_args: { uint8_t more_start = *(++pc); uint8_t key_count_info = *(++pc); uint8_t key_literal_start = *(++pc); @@ -501,25 +501,25 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure pc++; break; } - case vm_jump_8: { + case vm_code::jump_8: { int8_t rel = *(pc + 1); DBG_VM1("jump %" PRId8 "\n", rel); pc += rel; break; } - case vm_jump_16: { + case vm_code::jump_16: { int16_t rel = read_s16(pc + 1); DBG_VM("jump %" PRId16 "\n", rel); pc += rel; break; } - case vm_jump_24: { + case vm_code::jump_24: { int32_t rel = read_label(pc, 3); DBG_VM("jump %" PRId32 "\n", rel); pc += rel; break; } - case vm_jump_if_8: { + case vm_code::jump_if_8: { int8_t rel = *(pc + 1); DBG_VM1("jump-if %" PRId8 "\n", rel); T_sp tval((gctools::Tagged)vm.pop(sp)); @@ -530,7 +530,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure pc += 2; break; } - case vm_jump_if_16: { + case vm_code::jump_if_16: { int16_t rel = read_s16(pc + 1); DBG_VM("jump-if %" PRId16 "\n", rel); T_sp tval((gctools::Tagged)vm.pop(sp)); @@ -540,7 +540,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure pc += 3; break; } - case vm_jump_if_24: { + case vm_code::jump_if_24: { int32_t rel = read_label(pc, 3); DBG_VM("jump-if %" PRId32 "\n", rel); T_sp tval((gctools::Tagged)vm.pop(sp)); @@ -550,7 +550,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure pc += 4; break; } - case vm_jump_if_supplied_8: { + case vm_code::jump_if_supplied_8: { uint8_t slot = *(pc + 1); int32_t rel = *(pc + 2); DBG_VM("jump-if-supplied %" PRIu8 " %" PRId8 "\n", slot, rel); @@ -561,7 +561,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure pc += rel; break; } - case vm_jump_if_supplied_16: { + case vm_code::jump_if_supplied_16: { uint8_t slot = *(pc + 1); int16_t rel = read_s16(pc + 2); DBG_VM("jump-if-supplied %" PRIu8 " %" PRId16 "\n", slot, rel); @@ -572,7 +572,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure pc += rel; break; } - case vm_check_arg_count_LE: { + case vm_code::check_arg_count_LE: { uint8_t max_nargs = *(++pc); DBG_VM("check-arg-count<= %" PRIu8 "\n", max_nargs); if (lcc_nargs > max_nargs) { @@ -582,7 +582,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure pc++; break; } - case vm_check_arg_count_GE: { + case vm_code::check_arg_count_GE: { uint8_t min_nargs = *(++pc); DBG_VM("check-arg-count>= %" PRIu8 "\n", min_nargs); if (lcc_nargs < min_nargs) { @@ -592,7 +592,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure pc++; break; } - case vm_check_arg_count_EQ: { + case vm_code::check_arg_count_EQ: { uint8_t req_nargs = *(++pc); DBG_VM1("check-arg-count= %" PRIu8 "\n", req_nargs); if (lcc_nargs != req_nargs) { @@ -602,7 +602,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure pc++; break; } - case vm_push_values: { + case vm_code::push_values: { // TODO: Direct copy? DBG_VM("push-values\n"); size_t nvalues = multipleValues.getSize(); @@ -614,7 +614,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure pc++; break; } - case vm_append_values: { + case vm_code::append_values: { DBG_VM("append-values\n"); T_sp texisting_values((gctools::Tagged)vm.pop(sp)); size_t existing_values = texisting_values.unsafe_fixnum(); @@ -627,7 +627,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure pc++; break; } - case vm_pop_values: { + case vm_code::pop_values: { DBG_VM("pop-values\n"); T_sp texisting_values((gctools::Tagged)vm.pop(sp)); size_t existing_values = texisting_values.unsafe_fixnum(); @@ -638,7 +638,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure pc++; break; } - case vm_mv_call: { + case vm_code::mv_call: { DBG_VM("mv-call\n"); T_sp tnargs((gctools::Tagged)vm.pop(sp)); size_t nargs = tnargs.unsafe_fixnum(); @@ -655,7 +655,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure pc++; break; } - case vm_mv_call_receive_one: { + case vm_code::mv_call_receive_one: { DBG_VM("mv-call-receive-one\n"); T_sp tnargs((gctools::Tagged)vm.pop(sp)); size_t nargs = tnargs.unsafe_fixnum(); @@ -673,7 +673,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure pc++; break; } - case vm_mv_call_receive_fixed: { + case vm_code::mv_call_receive_fixed: { uint8_t nvals = *(++pc); DBG_VM("mv-call-receive-fixed %" PRIu8 "\n", nvals); T_sp tnargs((gctools::Tagged)vm.pop(sp)); @@ -695,21 +695,21 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure pc++; break; } - case vm_save_sp: { + case vm_code::save_sp: { uint8_t n = *(++pc); DBG_VM("save sp %" PRIu8 "\n", n); vm.savesp(fp, sp, n); pc++; break; } - case vm_restore_sp: { + case vm_code::restore_sp: { uint8_t n = *(++pc); DBG_VM("restore sp %" PRIu8 "\n", n); vm.restoresp(fp, sp, n); pc++; break; } - case vm_entry: { + case vm_code::entry: { uint8_t n = *(++pc); DBG_VM("entry %" PRIu8 "\n", n); pc++; @@ -735,7 +735,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure } break; } - case vm_exit_8: { + case vm_code::exit_8: { int8_t rel = *(pc + 1); DBG_VM("exit %" PRId8 "\n", rel); vm._pc = pc + rel; @@ -743,7 +743,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure TagbodyDynEnv_sp tde = gc::As_assert(ttde); sjlj_unwind(tde, 1); } - case vm_exit_16: { + case vm_code::exit_16: { int16_t rel = read_s16(pc + 1); DBG_VM("exit %" PRId16 "\n", rel); vm._pc = pc + rel; @@ -751,7 +751,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure TagbodyDynEnv_sp tde = gc::As_assert(ttde); sjlj_unwind(tde, 1); } - case vm_exit_24: { + case vm_code::exit_24: { int32_t rel = read_label(pc, 3); DBG_VM("exit %" PRId32 "\n", rel); vm._pc = pc + rel; @@ -759,15 +759,15 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure TagbodyDynEnv_sp tde = gc::As_assert(ttde); sjlj_unwind(tde, 1); } - case vm_entry_close: { + case vm_code::entry_close: { DBG_VM("entry-close\n"); // This sham return value just gets us out of the bytecode_vm call in - // vm_entry, above. + // vm_code::entry, above. vm._pc = pc + 1; vm._stackPointer = sp; return gctools::return_type(nil().raw_(), 0); } - case vm_catch_8: { + case vm_code::catch_8: { int8_t rel = *(pc + 1); DBG_VM("catch-8 %" PRId8 "\n", rel); unsigned char* target = pc + rel; @@ -787,7 +787,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure } break; } - case vm_catch_16: { + case vm_code::catch_16: { int16_t rel = read_s16(pc + 1); DBG_VM("catch-8 %" PRId16 "\n", rel); unsigned char* target = pc + rel; @@ -807,18 +807,18 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure } break; } - case vm_throw: { + case vm_code::_throw: { DBG_VM("throw\n"); T_sp tag((gctools::Tagged)(vm.pop(sp))); sjlj_throw(tag); } - case vm_catch_close: { + case vm_code::catch_close: { DBG_VM("entry-close\n"); vm._pc = pc + 1; vm._stackPointer = sp; return gctools::return_type(nil().raw_(), 0); } - case vm_special_bind: { + case vm_code::special_bind: { uint8_t c = *(++pc); DBG_VM("special-bind %" PRIu8 "\n", c); T_sp value((gctools::Tagged)(vm.pop(sp))); @@ -831,7 +831,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure pc = vm._pc; break; } - case vm_symbol_value: { + case vm_code::symbol_value: { uint8_t c = *(++pc); DBG_VM("symbol-value %" PRIu8 "\n", c); T_sp cell_sp((gctools::Tagged)literals[c]); @@ -840,7 +840,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure pc++; break; } - case vm_symbol_value_set: { + case vm_code::symbol_value_set: { uint8_t c = *(++pc); DBG_VM("symbol-value-set %" PRIu8 "\n", c); T_sp cell_sp((gctools::Tagged)literals[c]); @@ -850,7 +850,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure pc++; break; } - case vm_unbind: { + case vm_code::unbind: { DBG_VM("unbind\n"); vm._pc = pc + 1; vm._stackPointer = sp; @@ -859,7 +859,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure // (or vm_progv) return gctools::return_type(nil().raw_(), 0); } - case vm_progv: { + case vm_code::progv: { uint8_t c = *(++pc); // environment DBG_VM1("progv %" PRIu8 "\n", c); T_sp vals((gctools::Tagged)(vm.pop(sp))); @@ -870,10 +870,10 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure pc = vm._pc; break; } - case vm_fdefinition: { + case vm_code::fdefinition: { // We have function cells in the literals vector. While these are // themselves callable, we have to resolve the cell because we - // use vm_fdefinition for lookup of #'foo. + // use vm_code::fdefinition for lookup of #'foo. uint8_t c = *(++pc); DBG_VM1("fdefinition %" PRIu8 "\n", c); T_sp cell((gctools::Tagged)literals[c]); @@ -883,25 +883,25 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure pc++; break; } - case vm_nil: + case vm_code::nil: DBG_VM("nil\n"); vm.push(sp, nil().raw_()); pc++; break; - case vm_push: { + case vm_code::push: { DBG_VM1("push\n"); vm.push(sp, multipleValues.valueGet(0, multipleValues.getSize()).raw_()); pc++; break; } - case vm_pop: { + case vm_code::pop: { DBG_VM1("pop\n"); T_sp obj((gctools::Tagged)vm.pop(sp)); multipleValues.set1(obj); pc++; break; } - case vm_dup: { + case vm_code::dup: { DBG_VM1("dup\n"); T_O* obj = vm.pop(sp); vm.push(sp, obj); @@ -909,7 +909,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure pc++; break; } - case vm_fdesignator: { + case vm_code::fdesignator: { uint8_t c = *(++pc); // ignored environment parameter DBG_VM1("fdesignator %" PRIu8 "\n", c); T_sp desig((gctools::Tagged)vm.pop(sp)); @@ -919,7 +919,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure pc++; break; } - case vm_called_fdefinition: { + case vm_code::called_fdefinition: { // This is like FDEFINITION except that we know the result will // just be called. So, we can just use the cell directly // without checking fboundedness, and this is just like const. @@ -933,7 +933,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure pc++; break; } - case vm_protect: { + case vm_code::protect: { uint8_t c = *(++pc); DBG_VM("protect %" PRIu8 "\n", c); // Build a closure - this works mostly like make_closure. @@ -952,14 +952,14 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure return bytecode_vm(vm, literals, closed, closure, fp, sp, lcc_nargs, lcc_args); }, [&]() { eval::funcall(cleanup); }); - // copied from vm_call - required to avoid the cleanup's values + // copied from vm_code::call - required to avoid the cleanup's values // for... some reason. I'm not totally sure. multipleValues.setN(result.raw_(), result.number_of_values()); sp = vm._stackPointer; pc = vm._pc; break; } - case vm_cleanup: { + case vm_code::cleanup: { DBG_VM("cleanup\n"); vm._pc = pc + 1; vm._stackPointer = sp; @@ -968,7 +968,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure size_t nvalues = multipleValues.getSize(); return gctools::return_type(multipleValues.valueGet(0, nvalues).raw_(), nvalues); } - case vm_encell: { + case vm_code::encell: { // abbreviation for ref N; make-cell; set N uint8_t n = *(++pc); DBG_VM1("encell %" PRIu8 "\n", n); @@ -977,7 +977,7 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure pc++; break; } - case vm_long: { + case vm_code::_long: { // In a separate function to facilitate better icache utilization // by bytecode_vm (hopefully) pc++; @@ -999,8 +999,8 @@ bytecode_vm(VirtualMachine& vm, T_O** literals, T_O** closed, Closure_O* closure static unsigned char* long_dispatch(VirtualMachine& vm, unsigned char* pc, MultipleValues& multipleValues, T_O** literals, T_O** closed, Closure_O* closure, core::T_O** fp, core::T_O** sp, size_t lcc_nargs, core::T_O** lcc_args, uint8_t sub_opcode) { - switch (sub_opcode) { - case vm_ref: { + switch ((vm_code)sub_opcode) { + case vm_code::ref: { uint8_t low = *(pc + 1); uint16_t n = low + (*(pc + 2) << 8); DBG_VM1("long ref %" PRIu16 "\n", n); @@ -1008,7 +1008,7 @@ static unsigned char* long_dispatch(VirtualMachine& vm, unsigned char* pc, Multi pc += 3; break; } - case vm_const: { + case vm_code::_const: { uint8_t low = *(++pc); uint16_t n = low + (*(++pc) << 8); DBG_VM1("long const %" PRIu16 "\n", n); @@ -1018,7 +1018,7 @@ static unsigned char* long_dispatch(VirtualMachine& vm, unsigned char* pc, Multi pc++; break; } - case vm_closure: { + case vm_code::closure: { uint8_t low = *(pc + 1); uint16_t n = low + (*(pc + 2) << 8); DBG_VM1("long closure %" PRIu16 "\n", n); @@ -1026,7 +1026,7 @@ static unsigned char* long_dispatch(VirtualMachine& vm, unsigned char* pc, Multi pc += 3; break; } - case vm_call: { + case vm_code::call: { uint8_t low = *(pc + 1); uint16_t nargs = low + (*(pc + 2) << 8); DBG_VM1("long call %" PRIu16 "\n", nargs); @@ -1042,7 +1042,7 @@ static unsigned char* long_dispatch(VirtualMachine& vm, unsigned char* pc, Multi pc += 3; break; } - case vm_call_receive_one: { + case vm_code::call_receive_one: { uint8_t low = *(pc + 1); uint16_t nargs = low + (*(pc + 2) << 8); DBG_VM1("long call-receive-one %" PRIu16 "\n", nargs); @@ -1068,7 +1068,7 @@ static unsigned char* long_dispatch(VirtualMachine& vm, unsigned char* pc, Multi pc += 3; break; } - case vm_call_receive_fixed: { + case vm_code::call_receive_fixed: { uint8_t low_nargs = *(pc + 1); uint16_t nargs = low_nargs + (*(pc + 2) << 8); uint8_t low_nvals = *(pc + 3); @@ -1091,7 +1091,7 @@ static unsigned char* long_dispatch(VirtualMachine& vm, unsigned char* pc, Multi pc += 5; break; } - case vm_bind: { + case vm_code::bind: { uint8_t low_count = *(pc + 1); uint16_t count = low_count + (*(pc + 2) << 8); uint8_t low_offset = *(pc + 3); @@ -1102,7 +1102,7 @@ static unsigned char* long_dispatch(VirtualMachine& vm, unsigned char* pc, Multi pc += 5; break; } - case vm_set: { + case vm_code::set: { uint8_t low = *(pc + 1); uint16_t n = low + (*(pc + 2) << 8); DBG_VM("long set %" PRIu16 "\n", n); @@ -1110,7 +1110,7 @@ static unsigned char* long_dispatch(VirtualMachine& vm, unsigned char* pc, Multi pc += 3; break; } - case vm_fdefinition: { + case vm_code::fdefinition: { uint8_t low = *(++pc); uint16_t n = low + (*(++pc) << 8); DBG_VM1("long fdefinition %" PRIu16 "\n", n); @@ -1121,7 +1121,7 @@ static unsigned char* long_dispatch(VirtualMachine& vm, unsigned char* pc, Multi pc++; break; } - case vm_make_closure: { + case vm_code::make_closure: { uint8_t low = *(pc + 1); uint16_t c = low + (*(pc + 2) << 8); DBG_VM("long make-closure %" PRIu16 "\n", c); @@ -1137,7 +1137,7 @@ static unsigned char* long_dispatch(VirtualMachine& vm, unsigned char* pc, Multi pc += 3; break; } - case vm_make_uninitialized_closure: { + case vm_code::make_uninitialized_closure: { uint8_t low = *(pc + 1); uint16_t c = low + (*(pc + 2) << 8); DBG_VM("long make-uninitialized-closure %" PRIu16 "\n", c); @@ -1150,7 +1150,7 @@ static unsigned char* long_dispatch(VirtualMachine& vm, unsigned char* pc, Multi pc += 3; break; } - case vm_initialize_closure: { + case vm_code::initialize_closure: { uint8_t low = *(pc + 1); uint16_t c = low + (*(pc + 2) << 8); DBG_VM("long initialize-closure %" PRIu16 "\n", c); @@ -1166,7 +1166,7 @@ static unsigned char* long_dispatch(VirtualMachine& vm, unsigned char* pc, Multi pc += 3; break; } - case vm_bind_required_args: { + case vm_code::bind_required_args: { uint8_t low = *(pc + 1); uint16_t nargs = low + (*(pc + 2) << 8); DBG_VM("long bind-required-args %" PRIu16 "\n", nargs); @@ -1174,7 +1174,7 @@ static unsigned char* long_dispatch(VirtualMachine& vm, unsigned char* pc, Multi pc += 3; break; } - case vm_bind_optional_args: { + case vm_code::bind_optional_args: { uint8_t nreq_low = *(pc + 1); uint16_t nreq = nreq_low + (*(pc + 2) << 8); uint8_t nopt_low = *(pc + 3); @@ -1191,7 +1191,7 @@ static unsigned char* long_dispatch(VirtualMachine& vm, unsigned char* pc, Multi pc += 5; break; } - case vm_listify_rest_args: { + case vm_code::listify_rest_args: { uint8_t low = *(pc + 1); uint16_t start = low + (*(pc + 2) << 8); DBG_VM("long listify-rest-args %" PRIu16 "\n", start); @@ -1204,7 +1204,7 @@ static unsigned char* long_dispatch(VirtualMachine& vm, unsigned char* pc, Multi pc += 3; break; } - case vm_parse_key_args: { + case vm_code::parse_key_args: { uint8_t more_start_low = *(pc + 1); uint16_t more_start = more_start_low + (*(pc + 2) << 8); uint8_t key_count_info_low = *(pc + 3); @@ -1258,7 +1258,7 @@ static unsigned char* long_dispatch(VirtualMachine& vm, unsigned char* pc, Multi pc += 9; break; } - case vm_jump_if_supplied_8: { + case vm_code::jump_if_supplied_8: { uint8_t low = *(pc + 1); uint16_t slot = low + (*(pc + 2) << 8); int32_t rel = *(pc + 3); @@ -1270,7 +1270,7 @@ static unsigned char* long_dispatch(VirtualMachine& vm, unsigned char* pc, Multi pc += rel - 1; // -1 for the long opcode at pc-1 break; } - case vm_jump_if_supplied_16: { + case vm_code::jump_if_supplied_16: { uint8_t low = *(pc + 1); uint16_t slot = low + (*(pc + 2) << 8); int32_t rel = read_s16(pc + 3); @@ -1282,7 +1282,7 @@ static unsigned char* long_dispatch(VirtualMachine& vm, unsigned char* pc, Multi pc += rel - 1; // -1 for the long opcode at pc-1 break; } - case vm_check_arg_count_LE: { + case vm_code::check_arg_count_LE: { uint8_t low = *(pc + 1); uint16_t max_nargs = low + (*(pc + 2) << 8); DBG_VM("long check-arg-count<= %" PRIu16 "\n", max_nargs); @@ -1293,7 +1293,7 @@ static unsigned char* long_dispatch(VirtualMachine& vm, unsigned char* pc, Multi pc += 3; break; } - case vm_check_arg_count_GE: { + case vm_code::check_arg_count_GE: { uint8_t low = *(pc + 1); uint16_t min_nargs = low + (*(pc + 2) << 8); DBG_VM("long check-arg-count>= %" PRIu16 "\n", min_nargs); @@ -1304,7 +1304,7 @@ static unsigned char* long_dispatch(VirtualMachine& vm, unsigned char* pc, Multi pc += 3; break; } - case vm_check_arg_count_EQ: { + case vm_code::check_arg_count_EQ: { uint8_t low = *(pc + 1); uint16_t req_nargs = low + (*(pc + 2) << 8); DBG_VM1("long check-arg-count= %" PRIu16 "\n", req_nargs); @@ -1315,7 +1315,7 @@ static unsigned char* long_dispatch(VirtualMachine& vm, unsigned char* pc, Multi pc += 3; break; } - case vm_mv_call_receive_fixed: { + case vm_code::mv_call_receive_fixed: { uint8_t low = *(pc + 1); uint16_t nvals = low + (*(pc + 2) << 8); DBG_VM("long mv-call-receive-fixed %" PRIu16 "\n", nvals); @@ -1338,7 +1338,7 @@ static unsigned char* long_dispatch(VirtualMachine& vm, unsigned char* pc, Multi pc += 3; break; } - case vm_save_sp: { + case vm_code::save_sp: { uint8_t low = *(pc + 1); uint16_t n = low + (*(pc + 2) << 8); DBG_VM("long save sp %" PRIu16 "\n", n); @@ -1346,7 +1346,7 @@ static unsigned char* long_dispatch(VirtualMachine& vm, unsigned char* pc, Multi pc += 3; break; } - case vm_restore_sp: { + case vm_code::restore_sp: { uint8_t low = *(pc + 1); uint16_t n = low + (*(pc + 2) << 8); DBG_VM("long restore sp %" PRIu16 "\n", n); @@ -1354,7 +1354,7 @@ static unsigned char* long_dispatch(VirtualMachine& vm, unsigned char* pc, Multi pc += 3; break; } - case vm_entry: { + case vm_code::entry: { uint8_t low = *(++pc); uint16_t n = low + (*(++pc) << 8); DBG_VM("long entry %" PRIu16 "\n", n); @@ -1381,7 +1381,7 @@ static unsigned char* long_dispatch(VirtualMachine& vm, unsigned char* pc, Multi } break; } - case vm_special_bind: { + case vm_code::special_bind: { uint8_t low = *(pc + 1); uint16_t c = low + (*(pc + 2) << 8); DBG_VM("long special-bind %" PRIu16 "\n", c); @@ -1395,7 +1395,7 @@ static unsigned char* long_dispatch(VirtualMachine& vm, unsigned char* pc, Multi sp = vm._stackPointer; break; } - case vm_symbol_value: { + case vm_code::symbol_value: { uint8_t low = *(++pc); uint16_t n = low + (*(++pc) << 8); DBG_VM1("long symbol-value %" PRIu16 "\n", n); @@ -1405,7 +1405,7 @@ static unsigned char* long_dispatch(VirtualMachine& vm, unsigned char* pc, Multi pc++; break; } - case vm_symbol_value_set: { + case vm_code::symbol_value_set: { uint8_t low = *(++pc); uint16_t n = low + (*(++pc) << 8); DBG_VM1("long symbol-value %" PRIu16 "\n", n); @@ -1416,7 +1416,7 @@ static unsigned char* long_dispatch(VirtualMachine& vm, unsigned char* pc, Multi pc++; break; } - case vm_progv: { + case vm_code::progv: { uint8_t low = *(++pc); uint16_t c = low + (*(++pc) << 8); DBG_VM1("long progv %" PRIu16 "\n", c); @@ -1428,7 +1428,7 @@ static unsigned char* long_dispatch(VirtualMachine& vm, unsigned char* pc, Multi pc = vm._pc; break; } - case vm_fdesignator: { + case vm_code::fdesignator: { uint8_t low = *(++pc); uint16_t n = low + (*(++pc) << 8); DBG_VM1("long fdesignator %" PRIu16 "\n", n); @@ -1438,7 +1438,7 @@ static unsigned char* long_dispatch(VirtualMachine& vm, unsigned char* pc, Multi pc++; break; } - case vm_called_fdefinition: { + case vm_code::called_fdefinition: { uint8_t low = *(++pc); uint16_t n = low + (*(++pc) << 8); DBG_VM1("long called-fdefinition %" PRIu16 "\n", n); @@ -1448,7 +1448,7 @@ static unsigned char* long_dispatch(VirtualMachine& vm, unsigned char* pc, Multi pc++; break; } - case vm_protect: { + case vm_code::protect: { uint8_t low = *(++pc); uint16_t c = low + (*(++pc) << 8); DBG_VM1("long protect %" PRIu16 "\n", c); @@ -1469,7 +1469,7 @@ static unsigned char* long_dispatch(VirtualMachine& vm, unsigned char* pc, Multi pc = vm._pc; break; } - case vm_encell: { + case vm_code::encell: { uint8_t low = *(++pc); uint16_t n = low + (*(++pc) << 8); DBG_VM1("encell %" PRIu16 "\n", n); diff --git a/src/core/bytecode_compiler.cc b/src/core/bytecode_compiler.cc index 16e604b8e8..bcc1ab897e 100644 --- a/src/core/bytecode_compiler.cc +++ b/src/core/bytecode_compiler.cc @@ -9,10 +9,6 @@ #include #include // max -#define VM_CODES -#include -#undef VM_CODES - namespace comp { using namespace core; @@ -249,7 +245,7 @@ void assemble_maybe_long(const Context context, uint8_t opcode, List_sp operands } } if (longp) { - bytecode->vectorPushExtend(vm_long); + bytecode->vectorPushExtend((uint8_t)vm_code::_long); bytecode->vectorPushExtend(opcode); for (auto cur : operands) { uint16_t operand = clasp_to_integral(oCar(cur)); @@ -486,7 +482,8 @@ size_t Context::env_index() const { ComplexVector_T_sp literals = this->cfunction()->module()->literals(); for (size_t i = 0; i < literals->length(); ++i) { T_sp slit = (*literals)[i]; - if (gc::IsA(slit)) return i; + if (gc::IsA(slit)) + return i; } Fixnum_sp nind = literals->vectorPushExtend(EnvInfo_O::make()); return nind.unsafe_fixnum(); @@ -504,11 +501,11 @@ size_t Context::closure_index(T_sp info) const { void Context::push_debug_info(T_sp info) const { this->cfunction()->debug_info()->vectorPushExtend(info); } void Context::emit_jump(Label_sp label) const { - ControlLabelFixup_O::make(label, vm_jump_8, vm_jump_16, vm_jump_24)->contextualize(*this); + ControlLabelFixup_O::make(label, vm_code::jump_8, vm_code::jump_16, vm_code::jump_24)->contextualize(*this); } void Context::emit_jump_if(Label_sp label) const { - ControlLabelFixup_O::make(label, vm_jump_if_8, vm_jump_if_16, vm_jump_if_24)->contextualize(*this); + ControlLabelFixup_O::make(label, vm_code::jump_if_8, vm_code::jump_if_16, vm_code::jump_if_24)->contextualize(*this); } void Context::emit_entry_or_save_sp(LexicalInfo_sp dynenv) const { EntryFixup_O::make(dynenv)->contextualize(*this); } @@ -516,7 +513,7 @@ void Context::emit_entry_or_save_sp(LexicalInfo_sp dynenv) const { EntryFixup_O: void Context::emit_ref_or_restore_sp(LexicalInfo_sp dynenv) const { RestoreSPFixup_O::make(dynenv)->contextualize(*this); } void Context::emit_exit(Label_sp label) const { - ControlLabelFixup_O::make(label, vm_exit_8, vm_exit_16, vm_exit_24)->contextualize(*this); + ControlLabelFixup_O::make(label, vm_code::exit_8, vm_code::exit_16, vm_code::exit_24)->contextualize(*this); } void Context::emit_exit_or_jump(LexicalInfo_sp dynenv, Label_sp label) const { @@ -526,7 +523,7 @@ void Context::emit_exit_or_jump(LexicalInfo_sp dynenv, Label_sp label) const { void Context::maybe_emit_entry_close(LexicalInfo_sp dynenv) const { EntryCloseFixup_O::make(dynenv)->contextualize(*this); } void Context::emit_catch(Label_sp label) const { - ControlLabelFixup_O::make(label, vm_catch_8, vm_catch_16, 0)->contextualize(*this); + ControlLabelFixup_O::make(label, vm_code::catch_8, vm_code::catch_16, vm_code::catch_16)->contextualize(*this); } void Context::emit_jump_if_supplied(Label_sp label, size_t ind) const { @@ -536,17 +533,17 @@ void Context::emit_jump_if_supplied(Label_sp label, size_t ind) const { // Push the immutable value or cell of lexical in CONTEXT. void Context::reference_lexical_info(LexicalInfo_sp info) const { if (info->cfunction() == this->cfunction()) - this->assemble1(vm_ref, info->frameIndex()); + this->assemble1(vm_code::ref, info->frameIndex()); else - this->assemble1(vm_closure, this->closure_index(info)); + this->assemble1(vm_code::closure, this->closure_index(info)); } void Context::maybe_emit_make_cell(LexicalVarInfo_sp info) const { - LexRefFixup_O::make(info->lex(), vm_make_cell)->contextualize(*this); + LexRefFixup_O::make(info->lex(), vm_code::make_cell)->contextualize(*this); } void Context::maybe_emit_cell_ref(LexicalVarInfo_sp info) const { - LexRefFixup_O::make(info->lex(), vm_cell_ref)->contextualize(*this); + LexRefFixup_O::make(info->lex(), vm_code::cell_ref)->contextualize(*this); } void Context::maybe_emit_encage(LexicalVarInfo_sp info) const { EncageFixup_O::make(info->lex())->contextualize(*this); } @@ -556,14 +553,14 @@ void Context::emit_lexical_set(LexicalVarInfo_sp info) const { LexSetFixup_O::ma void Context::emit_parse_key_args(size_t max_count, size_t key_count, size_t keystart, size_t indx, bool aokp) const { ComplexVector_byte8_t_sp bytecode = this->cfunction()->bytecode(); if ((max_count < (1 << 8)) && (key_count < (1 << 8)) && (keystart < (1 << 8)) && (indx < (1 << 8))) { - bytecode->vectorPushExtend(vm_parse_key_args); + bytecode->vectorPushExtend((uint8_t)vm_code::parse_key_args); bytecode->vectorPushExtend(max_count); bytecode->vectorPushExtend(key_count | (aokp ? 0x80 : 0)); bytecode->vectorPushExtend(keystart); bytecode->vectorPushExtend(indx); } else if ((max_count < (1 << 16)) && (key_count < (1 << 16)) && (keystart < (1 << 16)) && (indx < (1 << 16))) { - bytecode->vectorPushExtend(vm_long); - bytecode->vectorPushExtend(vm_parse_key_args); + bytecode->vectorPushExtend((uint8_t)vm_code::_long); + bytecode->vectorPushExtend((uint8_t)vm_code::parse_key_args); bytecode->vectorPushExtend(max_count & 0xff); bytecode->vectorPushExtend(max_count >> 8); bytecode->vectorPushExtend(key_count & 0xff); @@ -577,31 +574,31 @@ void Context::emit_parse_key_args(size_t max_count, size_t key_count, size_t key indx); } -void Context::assemble0(uint8_t opcode) const { this->cfunction()->bytecode()->vectorPushExtend(opcode); } +void Context::assemble0(vm_code opcode) const { this->cfunction()->bytecode()->vectorPushExtend((uint8_t)opcode); } -void Context::assemble1(uint8_t opcode, size_t operand) const { +void Context::assemble1(vm_code opcode, size_t operand) const { ComplexVector_byte8_t_sp bytecode = this->cfunction()->bytecode(); if (operand < (1 << 8)) { - bytecode->vectorPushExtend(opcode); + bytecode->vectorPushExtend((uint8_t)opcode); bytecode->vectorPushExtend(operand); } else if (operand < (1 << 16)) { - bytecode->vectorPushExtend(vm_long); - bytecode->vectorPushExtend(opcode); + bytecode->vectorPushExtend((uint8_t)vm_code::_long); + bytecode->vectorPushExtend((uint8_t)opcode); bytecode->vectorPushExtend(operand & 0xff); bytecode->vectorPushExtend(operand >> 8); } else SIMPLE_ERROR("Bytecode compiler limit reached: operand %zu too large", operand); } -void Context::assemble2(uint8_t opcode, size_t operand1, size_t operand2) const { +void Context::assemble2(vm_code opcode, size_t operand1, size_t operand2) const { ComplexVector_byte8_t_sp bytecode = this->cfunction()->bytecode(); if ((operand1 < (1 << 8)) && (operand2 < (1 << 8))) { - bytecode->vectorPushExtend(opcode); + bytecode->vectorPushExtend((uint8_t)opcode); bytecode->vectorPushExtend(operand1); bytecode->vectorPushExtend(operand2); } else if ((operand1 < (1 << 16)) && (operand2 < (1 << 16))) { - bytecode->vectorPushExtend(vm_long); - bytecode->vectorPushExtend(opcode); + bytecode->vectorPushExtend((uint8_t)vm_code::_long); + bytecode->vectorPushExtend((uint8_t)opcode); bytecode->vectorPushExtend(operand1 & 0xff); bytecode->vectorPushExtend(operand1 >> 8); bytecode->vectorPushExtend(operand2 & 0xff); @@ -613,12 +610,12 @@ void Context::assemble2(uint8_t opcode, size_t operand1, size_t operand2) const void Context::emit_bind(size_t count, size_t offset) const { switch (count) { case 1: - this->assemble1(vm_set, offset); + this->assemble1(vm_code::set, offset); break; case 0: break; default: - this->assemble2(vm_bind, count, offset); + this->assemble2(vm_code::bind, count, offset); break; } } @@ -626,13 +623,13 @@ void Context::emit_bind(size_t count, size_t offset) const { void Context::emit_call(size_t argcount) const { switch (this->receiving()) { case 1: - this->assemble1(vm_call_receive_one, argcount); + this->assemble1(vm_code::call_receive_one, argcount); break; case -1: - this->assemble1(vm_call, argcount); + this->assemble1(vm_code::call, argcount); break; default: - this->assemble2(vm_call_receive_fixed, argcount, this->receiving()); + this->assemble2(vm_code::call_receive_fixed, argcount, this->receiving()); break; } } @@ -640,22 +637,22 @@ void Context::emit_call(size_t argcount) const { void Context::emit_mv_call() const { switch (this->receiving()) { case 1: - this->assemble0(vm_mv_call_receive_one); + this->assemble0(vm_code::mv_call_receive_one); break; case -1: - this->assemble0(vm_mv_call); + this->assemble0(vm_code::mv_call); break; default: - this->assemble1(vm_mv_call_receive_fixed, this->receiving()); + this->assemble1(vm_code::mv_call_receive_fixed, this->receiving()); break; } } -void Context::emit_special_bind(Symbol_sp sym) const { this->assemble1(vm_special_bind, this->vcell_index(sym)); } +void Context::emit_special_bind(Symbol_sp sym) const { this->assemble1(vm_code::special_bind, this->vcell_index(sym)); } void Context::emit_unbind(size_t count) const { for (size_t i = 0; i < count; ++i) - this->assemble0(vm_unbind); + this->assemble0(vm_code::unbind); } size_t Annotation_O::module_position() { return this->pposition() + gc::As_assert(this->cfunction())->pposition(); } @@ -683,18 +680,18 @@ void Fixup_O::contextualize(const Context ctxt) { ptrdiff_t LabelFixup_O::delta() { return this->label()->module_position() - this->module_position(); } -static void emit_control_label_fixup(size_t size, size_t offset, size_t position, SimpleVector_byte8_t_sp code, uint8_t opcode8, - uint8_t opcode16, uint8_t opcode24) { +static void emit_control_label_fixup(size_t size, size_t offset, size_t position, SimpleVector_byte8_t_sp code, vm_code opcode8, + vm_code opcode16, vm_code opcode24) { // Offset is a size_t so it's a positive integer i.e. dumpable. switch (size) { case 2: - (*code)[position] = opcode8; + (*code)[position] = (uint8_t)opcode8; break; case 3: - (*code)[position] = opcode16; + (*code)[position] = (uint8_t)opcode16; break; case 4: - (*code)[position] = opcode24; + (*code)[position] = (uint8_t)opcode24; break; default: SIMPLE_ERROR("Assembler bug: Impossible size %zu", size); @@ -726,23 +723,23 @@ size_t ControlLabelFixup_O::resize() { return resize_control_label_fixup(this->d void JumpIfSuppliedFixup_O::emit(size_t position, SimpleVector_byte8_t_sp code) { uint16_t index = this->iindex(); if (index > 0xff) - (*code)[position++] = vm_long; + (*code)[position++] = (uint8_t)vm_code::_long; size_t size = this->size(); bool s16 = false; switch (size) { case 3: - (*code)[position++] = vm_jump_if_supplied_8; + (*code)[position++] = (uint8_t)vm_code::jump_if_supplied_8; break; case 4: s16 = true; - (*code)[position++] = vm_jump_if_supplied_16; + (*code)[position++] = (uint8_t)vm_code::jump_if_supplied_16; break; case 5: - (*code)[position++] = vm_jump_if_supplied_8; + (*code)[position++] = (uint8_t)vm_code::jump_if_supplied_8; break; case 6: s16 = true; - (*code)[position] = vm_jump_if_supplied_16; + (*code)[position] = (uint8_t)vm_code::jump_if_supplied_16; break; default: SIMPLE_ERROR("Assembler bug: Impossible size %zu", size); @@ -760,11 +757,16 @@ size_t JumpIfSuppliedFixup_O::resize() { ptrdiff_t delta = this->delta(); uint16_t index = this->iindex(); if ((-(1 << 7) <= delta) && (delta <= (1 << 7) - 1)) { - if (index > 0xff) return 5; - else return 3; - } if ((-(1 << 15) <= delta) && (delta <= (1 << 15) - 1)) { - if (index > 0xff) return 6; - else return 4; + if (index > 0xff) + return 5; + else + return 3; + } + if ((-(1 << 15) <= delta) && (delta <= (1 << 15) - 1)) { + if (index > 0xff) + return 6; + else + return 4; } else SIMPLE_ERROR("Bytecode compiler limit reached: Fixup delta too large"); } @@ -773,7 +775,7 @@ void LexRefFixup_O::emit(size_t position, SimpleVector_byte8_t_sp code) { size_t size = this->size(); switch (size) { case 1: - (*code)[position] = this->opcode(); + (*code)[position] = (uint8_t)this->opcode(); break; default: UNREACHABLE(); @@ -787,12 +789,12 @@ void EncageFixup_O::emit(size_t position, SimpleVector_byte8_t_sp code) { size_t index = this->lex()->frameIndex(); switch (size) { case 2: // FIXME: Use assemble_into? - (*code)[position] = vm_encell; + (*code)[position] = (uint8_t)vm_code::encell; (*code)[position + 1] = index; break; case 4: - (*code)[position] = vm_long; - (*code)[position + 1] = vm_encell; + (*code)[position] = (uint8_t)vm_code::_long; + (*code)[position + 1] = (uint8_t)vm_code::encell; (*code)[position + 2] = index & 0xff; (*code)[position + 3] = index >> 8; break; @@ -818,26 +820,26 @@ void LexSetFixup_O::emit(size_t position, SimpleVector_byte8_t_sp code) { size_t index = this->lex()->frameIndex(); switch (size) { case 2: - (*code)[position] = vm_set; + (*code)[position] = (uint8_t)vm_code::set; (*code)[position + 1] = index; break; case 3: - (*code)[position] = vm_ref; + (*code)[position] = (uint8_t)vm_code::ref; (*code)[position + 1] = index; - (*code)[position + 2] = vm_cell_set; + (*code)[position + 2] = (uint8_t)vm_code::cell_set; break; case 4: - (*code)[position] = vm_long; - (*code)[position + 1] = vm_set; + (*code)[position] = (uint8_t)vm_code::_long; + (*code)[position + 1] = (uint8_t)vm_code::set; (*code)[position + 2] = index & 0xff; (*code)[position + 3] = index >> 8; break; case 5: - (*code)[position] = vm_long; - (*code)[position + 1] = vm_ref; + (*code)[position] = (uint8_t)vm_code::_long; + (*code)[position + 1] = (uint8_t)vm_code::ref; (*code)[position + 2] = index & 0xff; (*code)[position + 3] = index >> 8; - (*code)[position + 4] = vm_cell_set; + (*code)[position + 4] = (uint8_t)vm_code::cell_set; break; default: UNREACHABLE(); @@ -864,11 +866,11 @@ size_t LexSetFixup_O::resize() { void EntryFixup_O::emit(size_t position, SimpleVector_byte8_t_sp code) { size_t index = this->lex()->frameIndex(); if (index >= 1 << 8) - (*code)[position++] = vm_long; + (*code)[position++] = (uint8_t)vm_code::_long; if (this->lex()->closedOverP()) - (*code)[position] = vm_entry; + (*code)[position] = (uint8_t)vm_code::entry; else - (*code)[position] = vm_save_sp; + (*code)[position] = (uint8_t)vm_code::save_sp; if (index < 1 << 8) (*code)[position + 1] = index; else { @@ -882,11 +884,11 @@ size_t EntryFixup_O::resize() { return (this->lex()->frameIndex() < 1 << 8) ? 2 void RestoreSPFixup_O::emit(size_t position, SimpleVector_byte8_t_sp code) { size_t index = this->lex()->frameIndex(); if (index >= 1 << 8) - (*code)[position++] = vm_long; + (*code)[position++] = (uint8_t)vm_code::_long; if (this->lex()->closedOverP()) - (*code)[position] = vm_ref; + (*code)[position] = (uint8_t)vm_code::ref; else - (*code)[position] = vm_restore_sp; + (*code)[position] = (uint8_t)vm_code::restore_sp; if (index < 1 << 8) (*code)[position + 1] = index; else { @@ -899,9 +901,9 @@ size_t RestoreSPFixup_O::resize() { return (this->lex()->frameIndex() < 1 << 8) void ExitFixup_O::emit(size_t position, SimpleVector_byte8_t_sp code) { if (this->lex()->closedOverP()) - emit_control_label_fixup(this->size(), this->delta(), position, code, vm_exit_8, vm_exit_16, vm_exit_24); + emit_control_label_fixup(this->size(), this->delta(), position, code, vm_code::exit_8, vm_code::exit_16, vm_code::exit_24); else - emit_control_label_fixup(this->size(), this->delta(), position, code, vm_jump_8, vm_jump_16, vm_jump_24); + emit_control_label_fixup(this->size(), this->delta(), position, code, vm_code::jump_8, vm_code::jump_16, vm_code::jump_24); } size_t ExitFixup_O::resize() { return resize_control_label_fixup(this->delta()); } @@ -909,7 +911,7 @@ size_t ExitFixup_O::resize() { return resize_control_label_fixup(this->delta()); void EntryCloseFixup_O::emit(size_t position, SimpleVector_byte8_t_sp code) { switch (this->size()) { case 1: - (*code)[position] = vm_entry_close; + (*code)[position] = (uint8_t)vm_code::entry_close; break; default: UNREACHABLE(); @@ -1001,9 +1003,7 @@ static void resolve_debug_vars(BytecodeDebugVars_sp info) { if (gc::IsA(tlvinfo)) { T_sp name = entry->car(); LexicalInfo_sp lvinfo = gc::As_unsafe(tlvinfo); - auto bdv = BytecodeDebugVar_O::make(name, lvinfo->frameIndex(), - lvinfo->indirectLexicalP(), - lvinfo->decls()); + auto bdv = BytecodeDebugVar_O::make(name, lvinfo->frameIndex(), lvinfo->indirectLexicalP(), lvinfo->decls()); cur->setCar(bdv); } } @@ -1108,9 +1108,7 @@ Function_sp Cfunction_O::link_function() { // For using a cfunction as a debug info (in BTB). // These only work after the module has been linked. CL_LISPIFY_NAME("core:bytecode-debug-info/start") -CL_DEFMETHOD T_sp Cfunction_O::start() const { - return clasp_make_fixnum(this->entry_point()->module_position()); -} +CL_DEFMETHOD T_sp Cfunction_O::start() const { return clasp_make_fixnum(this->entry_point()->module_position()); } CL_LISPIFY_NAME("core:bytecode-debug-info/end") CL_DEFMETHOD T_sp Cfunction_O::end() const { return clasp_make_fixnum(this->entry_point()->module_position() + this->final_size()); @@ -1184,8 +1182,8 @@ void Module_O::link_load() { Fixnum_sp ep = clasp_make_fixnum(cfunction->entry_point()->module_position()); Pointer_sp trampoline = llvmo::cmp__compile_trampoline(cfunction->nname()); BytecodeSimpleFun_sp func = - core__makeBytecodeSimpleFun(fdesc, bytecode_module, cfunction->nlocals(), cfunction->closed()->length(), - ep.unsafe_fixnum(), cfunction->final_size(), trampoline); + core__makeBytecodeSimpleFun(fdesc, bytecode_module, cfunction->nlocals(), cfunction->closed()->length(), ep.unsafe_fixnum(), + cfunction->final_size(), trampoline); cfunction->setInfo(func); } // Replace the cfunctions in the cmodule literal vector with @@ -1211,8 +1209,8 @@ void Module_O::link_load() { (*literals)[i] = gc::As_unsafe(lit)->vname()->ensureVariableCell(); else if (gc::IsA(lit)) (*literals)[i] = nil(); // the only environment we have - else SIMPLE_ERROR("BUG: Weird thing in compiler literals vector: {}", - _rep_(lit)); + else + SIMPLE_ERROR("BUG: Weird thing in compiler literals vector: {}", _rep_(lit)); } // Also replace the cfunctions in the debug info. // We just modify the vector rather than cons a new one since create_debug_info @@ -1249,16 +1247,16 @@ void compile_literal(T_sp literal, Lexenv_sp env, const Context context) { return; // No value required, so do nothing case 1: if (literal.nilp()) - context.assemble0(vm_nil); + context.assemble0(vm_code::nil); else - context.assemble1(vm_const, context.literal_index(literal)); + context.assemble1(vm_code::_const, context.literal_index(literal)); return; case -1: // values if (literal.nilp()) - context.assemble0(vm_nil); + context.assemble0(vm_code::nil); else - context.assemble1(vm_const, context.literal_index(literal)); - context.assemble0(vm_pop); + context.assemble1(vm_code::_const, context.literal_index(literal)); + context.assemble0(vm_code::pop); return; default: // FIXME: Just need to pad in some NILs. @@ -1297,13 +1295,13 @@ inline static bool code_walking_p() { SYMBOL_EXPORT_SC_(CompPkg, warn_used_ignored_variable); CL_DEFUN void cmp__warn_used_ignored_variable(T_sp name, T_sp sourceloc) { - (void)name; (void)sourceloc; + (void)name; + (void)sourceloc; } // Function is called whenever a lexical is referenced, to issue a // warning with appropriate source location. -static void maybe_warn_used(T_sp name, LexicalInfo_sp lex, - T_sp sloc, bool funp) { +static void maybe_warn_used(T_sp name, LexicalInfo_sp lex, T_sp sloc, bool funp) { if (lex->ignore() == LexicalInfo_O::IgnoreStatus::IGNORE) { T_sp rname = funp ? Cons_O::createList(cl::_sym_Function_O, name) : name; eval::funcall(_sym_warn_used_ignored_variable, rname, sloc); @@ -1333,16 +1331,16 @@ void compile_symbol(Symbol_sp sym, Lexenv_sp env, const Context context) { LexicalVarInfo_sp lvinfo = std::get(info).info(); if (lvinfo->funct() == context.cfunction()) // Local variable, just read it. - context.assemble1(vm_ref, lvinfo->frameIndex()); + context.assemble1(vm_code::ref, lvinfo->frameIndex()); else { // closed over lvinfo->setClosedOverP(true); - context.assemble1(vm_closure, context.closure_index(lvinfo->lex())); + context.assemble1(vm_code::closure, context.closure_index(lvinfo->lex())); } context.maybe_emit_cell_ref(lvinfo); lvinfo->lex()->setReadP(true); maybe_warn_used(sym, lvinfo->lex(), context.source_info(), false); } else if (std::holds_alternative(info)) - context.assemble1(vm_symbol_value, context.vcell_index(sym)); + context.assemble1(vm_code::symbol_value, context.vcell_index(sym)); else if (std::holds_alternative(info)) { compile_literal(std::get(info).value(), env, context); // Avoid the pop code below - compile-literal handles it. @@ -1350,11 +1348,11 @@ void compile_symbol(Symbol_sp sym, Lexenv_sp env, const Context context) { } else if (std::holds_alternative(info)) { if (_sym_warn_undefined_global_variable->fboundp() && !code_walking_p()) eval::funcall(_sym_warn_undefined_global_variable, context.source_info(), sym); - context.assemble1(vm_symbol_value, context.vcell_index(sym)); + context.assemble1(vm_code::symbol_value, context.vcell_index(sym)); } if (context.receiving() == -1) // Values return - put value in mv vector. - context.assemble0(vm_pop); + context.assemble0(vm_code::pop); } } @@ -1405,7 +1403,8 @@ bool special_binding_p(Symbol_sp sym, List_sp specials, Lexenv_sp env) { LexicalInfo_O::IgnoreStatus binding_ignore(T_sp name, List_sp decls) { for (auto cur : decls) { T_sp decl = oCar(cur); - if (!gc::IsA(decl) || !gc::IsA(oCdr(decl))) continue; + if (!gc::IsA(decl) || !gc::IsA(oCdr(decl))) + continue; if (oCar(decl) == cl::_sym_ignore) { for (auto cv : gc::As_unsafe(oCdr(decl))) { if (cl__equal(oCar(cv), name)) @@ -1426,26 +1425,28 @@ LexicalInfo_O::IgnoreStatus binding_ignore(T_sp name, List_sp decls) { SYMBOL_EXPORT_SC_(CompPkg, warn_unused_variable); SYMBOL_EXPORT_SC_(CompPkg, warn_set_unused_variable); CL_DEFUN void cmp__warn_unused_variable(T_sp name, T_sp sourceloc) { - (void)name; (void)sourceloc; + (void)name; + (void)sourceloc; } -CL_DEFUN void cmp__warn_set_unused_variable(T_sp name, T_sp sourceloc) -{ - (void)name; (void)sourceloc; +CL_DEFUN void cmp__warn_set_unused_variable(T_sp name, T_sp sourceloc) { + (void)name; + (void)sourceloc; } // Emit warnings for unused variables etc. // Bindings is an alist of (name . lexical-info). static void warn_ignorance(List_sp bindings) { - if (code_walking_p()) return; + if (code_walking_p()) + return; for (auto cur : bindings) { LexicalInfo_sp lex = gc::As_assert(oCadar(cur)); - if (lex->ignore() == LexicalInfo_O::IgnoreStatus::NOIGNORE - && !lex->readP()) { + if (lex->ignore() == LexicalInfo_O::IgnoreStatus::NOIGNORE && !lex->readP()) { T_sp name = oCaar(cur); T_sp sloc = oCaddar(cur); if (lex->setP()) eval::funcall(_sym_warn_set_unused_variable, name, sloc); - else eval::funcall(_sym_warn_unused_variable, name, sloc); + else + eval::funcall(_sym_warn_unused_variable, name, sloc); } } } @@ -1500,8 +1501,7 @@ static List_sp decls_for_fun(T_sp funname, List_sp decls) { if (spec == cl::_sym_dynamic_extent || spec == cl::_sym_ignore || spec == cl::_sym_ignorable) { for (auto ncur : (List_sp)rest) { T_sp ncurn = oCar(ncur); - if (gc::IsA(ncurn) && oCar(ncurn) == cl::_sym_Function_O - && oCadr(ncurn) == funname && oCddr(ncurn).nilp()) { + if (gc::IsA(ncurn) && oCar(ncurn) == cl::_sym_Function_O && oCadr(ncurn) == funname && oCddr(ncurn).nilp()) { result << spec; break; } @@ -1532,7 +1532,7 @@ void compile_let(List_sp bindings, List_sp body, Lexenv_sp env, const Context ct Label_sp begin_label = Label_O::make(); Label_sp end_label = Label_O::make(); ql::list debug_bindings; // alist (name . LexicalInfo) - ql::list ibindings; // (name lex source). FIXME merge w/ above. + ql::list ibindings; // (name lex source). FIXME merge w/ above. // now get processing for (auto cur : bindings) { T_sp binding = oCar(cur); @@ -1555,8 +1555,7 @@ void compile_let(List_sp bindings, List_sp body, Lexenv_sp env, const Context ct ++lexical_binding_count; LexicalVarInfo_sp lvinfo = gc::As_assert(post_binding_env->variableInfo(var)); debug_bindings << Cons_O::create(var, lvinfo->lex()); - ibindings << Cons_O::createList(var, lvinfo->lex(), - source_location_for(binding, ctxt.source_info())); + ibindings << Cons_O::createList(var, lvinfo->lex(), source_location_for(binding, ctxt.source_info())); lvinfo->lex()->setIgnore(binding_ignore(var, declares)); lvinfo->lex()->setDecls(decls_for_var(var, declares)); ctxt.maybe_emit_make_cell(lvinfo); @@ -1613,7 +1612,7 @@ void compile_letSTAR(List_sp bindings, List_sp body, Lexenv_sp env, const Contex new_env = new_env->bind1var(var, ctxt); LexicalVarInfo_sp lvinfo = gc::As_assert(new_env->variableInfo(var)); ctxt.maybe_emit_make_cell(lvinfo); - ctxt.assemble1(vm_set, frame_start); + ctxt.assemble1(vm_code::set, frame_start); lvinfo->lex()->setIgnore(binding_ignore(var, declares)); lvinfo->lex()->setDecls(decls_for_var(var, declares)); // Set up debug info @@ -1621,8 +1620,7 @@ void compile_letSTAR(List_sp bindings, List_sp body, Lexenv_sp env, const Contex Cons_sp dpair = Cons_O::create(var, lvinfo->lex()); ctxt.push_debug_info(BytecodeDebugVars_O::make(begin_label, end_label, Cons_O::createList(dpair))); debug_bindings << dpair; - ibindings << Cons_O::createList(var, lvinfo->lex(), - source_location_for(binding, ctxt.source_info())); + ibindings << Cons_O::createList(var, lvinfo->lex(), source_location_for(binding, ctxt.source_info())); } } new_env = new_env->add_decls(declares); @@ -1656,8 +1654,8 @@ static T_sp extract_lambda_list_from_declares(List_sp declares, T_sp defaultll) return defaultll; } -Lexenv_sp compile_optional_or_key_item(Symbol_sp var, T_sp defaulting_form, LexicalVarInfo_sp varinfo, Symbol_sp supplied_var, bool var_specialp, bool supplied_specialp, const Context context, - Lexenv_sp env) { +Lexenv_sp compile_optional_or_key_item(Symbol_sp var, T_sp defaulting_form, LexicalVarInfo_sp varinfo, Symbol_sp supplied_var, + bool var_specialp, bool supplied_specialp, const Context context, Lexenv_sp env) { Label_sp supplied_label = Label_O::make(); Label_sp next_label = Label_O::make(); context.emit_jump_if_supplied(supplied_label, varinfo->frameIndex()); @@ -1669,7 +1667,7 @@ Lexenv_sp compile_optional_or_key_item(Symbol_sp var, T_sp defaulting_form, Lexi // Bind the var to the default, and the suppliedvar to NIL if applicable. // We push the suppliedp value first because it's bound second. if (supplied_var.notnilp()) - context.assemble0(vm_nil); + context.assemble0(vm_code::nil); compile_form(defaulting_form, env, context.sub_receiving(1)); // And actually set the variable, if we're lexical. context.emit_jump(next_label); @@ -1690,7 +1688,7 @@ Lexenv_sp compile_optional_or_key_item(Symbol_sp var, T_sp defaulting_form, Lexi supplied_label->contextualize(context); if (supplied_var.notnilp()) compile_literal(cl::_sym_T_O, env, context.sub_receiving(1)); - context.assemble1(vm_ref, varinfo->frameIndex()); + context.assemble1(vm_code::ref, varinfo->frameIndex()); next_label->contextualize(context); // Bind the main variable if it's special. // We emit this one special bind after the branch for the same reason as with the @@ -1699,7 +1697,7 @@ Lexenv_sp compile_optional_or_key_item(Symbol_sp var, T_sp defaulting_form, Lexi context.emit_special_bind(var); else { context.maybe_emit_make_cell(varinfo); - context.assemble1(vm_set, varinfo->frameIndex()); + context.assemble1(vm_code::set, varinfo->frameIndex()); } // The suppliedp value was pushed most recently, so bind that first. // We do it this way after the branch so that the suppliedp var has a dominating bind @@ -1712,7 +1710,7 @@ Lexenv_sp compile_optional_or_key_item(Symbol_sp var, T_sp defaulting_form, Lexi context.maybe_emit_make_cell(lsinfo); // This is a separate set because the variable and its optionalp usually // don't have contiguous indices. - context.assemble1(vm_set, lsinfo->frameIndex()); + context.assemble1(vm_code::set, lsinfo->frameIndex()); } } // That's it for code generation. Now return the new environment. @@ -1721,10 +1719,8 @@ Lexenv_sp compile_optional_or_key_item(Symbol_sp var, T_sp defaulting_form, Lexi // Generate BytecodeDebug whatsits for optional/key variables. // Also set the ignore and other declarations. -void annotate_optional_or_key_item(Symbol_sp key_var, Symbol_sp supplied_var, - List_sp decls, Label_sp end, - const Context ctxt, Lexenv_sp env) -{ +void annotate_optional_or_key_item(Symbol_sp key_var, Symbol_sp supplied_var, List_sp decls, Label_sp end, const Context ctxt, + Lexenv_sp env) { ql::list dvars; VarInfoV kinfo = var_info_v(key_var, env); if (std::holds_alternative(kinfo)) { @@ -1774,7 +1770,7 @@ void compile_with_lambda_list(T_sp lambda_list, List_sp body, Lexenv_sp env, con size_t max_count = min_count + optional_count; bool morep = restarg._ArgTarget.notnilp() || key_flag.notnilp(); Label_sp end_label = Label_O::make(); // for debug info - ql::list ibindings; // for ignore. &optional/&key not included FIXME + ql::list ibindings; // for ignore. &optional/&key not included FIXME ql::list lreqs; for (auto& it : reqs) lreqs << it._ArgTarget; @@ -1785,17 +1781,17 @@ void compile_with_lambda_list(T_sp lambda_list, List_sp body, Lexenv_sp env, con entry_point->contextualize(context); // Generate argument count check. if ((min_count > 0) && (min_count == max_count) && !morep) - context.assemble1(vm_check_arg_count_EQ, min_count); + context.assemble1(vm_code::check_arg_count_EQ, min_count); else { if (min_count > 0) - context.assemble1(vm_check_arg_count_GE, min_count); + context.assemble1(vm_code::check_arg_count_GE, min_count); if (!morep) - context.assemble1(vm_check_arg_count_LE, max_count); + context.assemble1(vm_code::check_arg_count_LE, max_count); } if (min_count > 0) { Label_sp begin_label = Label_O::make(); // Bind the required arguments. - context.assemble1(vm_bind_required_args, min_count); + context.assemble1(vm_code::bind_required_args, min_count); ql::list debugbindings; ql::list debugdecls; ql::list sreqs; // required parameters that are special @@ -1806,7 +1802,7 @@ void compile_with_lambda_list(T_sp lambda_list, List_sp body, Lexenv_sp env, con auto lvinfo = gc::As_assert(new_env->variableInfo(var)); if (special_binding_p(var, specials, env)) { sreqs << var; - context.assemble1(vm_ref, lvinfo->frameIndex()); + context.assemble1(vm_code::ref, lvinfo->frameIndex()); context.emit_special_bind(var); ++special_binding_count; // not in lisp - bug? } else { @@ -1815,8 +1811,7 @@ void compile_with_lambda_list(T_sp lambda_list, List_sp body, Lexenv_sp env, con debugbindings << dpair; lvinfo->lex()->setIgnore(binding_ignore(var, declares)); lvinfo->lex()->setDecls(decls_for_var(var, declares)); - ibindings << Cons_O::createList(var, lvinfo->lex(), - context.source_info()); + ibindings << Cons_O::createList(var, lvinfo->lex(), context.source_info()); } } new_env = new_env->add_specials(sreqs.cons()); @@ -1827,7 +1822,7 @@ void compile_with_lambda_list(T_sp lambda_list, List_sp body, Lexenv_sp env, con if (optional_count > 0) { // Generate code to bind the provided optional args, unprovided args will // be initialized with the unbound marker. - context.assemble2(vm_bind_optional_args, min_count, optional_count); + context.assemble2(vm_code::bind_optional_args, min_count, optional_count); // Mark the locations of each optional. Note that we do this even if // the variable will be specially bound, to match the placement by // bind_optional_args. @@ -1846,15 +1841,15 @@ void compile_with_lambda_list(T_sp lambda_list, List_sp body, Lexenv_sp env, con Symbol_sp rest = restarg._ArgTarget; bool varestp = restarg.VaRest; if (varestp) { - context.assemble1(vm_vaslistify_rest_args, max_count); + context.assemble1(vm_code::vaslistify_rest_args, max_count); } else { - context.assemble1(vm_listify_rest_args, max_count); + context.assemble1(vm_code::listify_rest_args, max_count); } new_env = new_env->bind1var(rest, context); optkey_env = optkey_env->bind1var(rest, context); auto lvinfo = gc::As_assert(new_env->variableInfo(rest)); if (special_binding_p(rest, specials, env)) { - context.assemble1(vm_ref, lvinfo->frameIndex()); + context.assemble1(vm_code::ref, lvinfo->frameIndex()); context.emit_special_bind(rest); ++special_binding_count; new_env = new_env->add_specials(Cons_O::createList(rest)); @@ -1905,15 +1900,14 @@ void compile_with_lambda_list(T_sp lambda_list, List_sp body, Lexenv_sp env, con bool supplied_special_p = supplied_var.notnilp() && special_binding_p(supplied_var, specials, env); new_env = compile_optional_or_key_item(optional_var, defaulting_form, varinfo, supplied_var, optional_special_p, supplied_special_p, context, new_env); - annotate_optional_or_key_item(optional_var, supplied_var, declares, end_label, - context, new_env); + annotate_optional_or_key_item(optional_var, supplied_var, declares, end_label, context, new_env); if (optional_special_p) ++special_binding_count; else ibindings << Cons_O::createList(optional_var, varinfo->lex(), context.source_info()); if (supplied_special_p) ++special_binding_count; - else if (supplied_var.notnilp()){ + else if (supplied_var.notnilp()) { T_sp lexvarinfo = var_info(supplied_var, new_env); ibindings << Cons_O::createList(supplied_var, gc::As_assert(lexvarinfo)->lex(), context.source_info()); } @@ -1928,10 +1922,9 @@ void compile_with_lambda_list(T_sp lambda_list, List_sp body, Lexenv_sp env, con bool key_special_p = special_binding_p(key_var, specials, env); auto varinfo = gc::As_assert(var_info(key_var, optkey_env)); bool supplied_special_p = supplied_var.notnilp() && special_binding_p(supplied_var, specials, env); - new_env = compile_optional_or_key_item(key_var, defaulting_form, varinfo, supplied_var, key_special_p, - supplied_special_p, context, new_env); - annotate_optional_or_key_item(key_var, supplied_var, declares, - end_label, context, new_env); + new_env = compile_optional_or_key_item(key_var, defaulting_form, varinfo, supplied_var, key_special_p, supplied_special_p, + context, new_env); + annotate_optional_or_key_item(key_var, supplied_var, declares, end_label, context, new_env); if (key_special_p) ++special_binding_count; else @@ -1939,7 +1932,8 @@ void compile_with_lambda_list(T_sp lambda_list, List_sp body, Lexenv_sp env, con if (supplied_special_p) ++special_binding_count; else if (supplied_var.notnilp()) - ibindings << Cons_O::createList(supplied_var, gc::As_assert(var_info(supplied_var, new_env))->lex(), context.source_info()); + ibindings << Cons_O::createList(supplied_var, gc::As_assert(var_info(supplied_var, new_env))->lex(), + context.source_info()); } } // Generate aux and the body as a let*. @@ -1991,7 +1985,7 @@ CL_DEFUN Cfunction_sp compile_lambda(T_sp lambda_list, List_sp body, Lexenv_sp e // We pass the original body w/declarations to compile-with-lambda-list // so that it can do its own handling of specials, etc. compile_with_lambda_list(lambda_list, body, lenv, context); - context.assemble0(vm_return); + context.assemble0(vm_code::_return); if (all_declares.notnilp() || source_info.notnilp()) end->contextualize(context); return function; @@ -2019,16 +2013,16 @@ void compile_function(T_sp fnameoid, Lexenv_sp env, const Context ctxt) { ctxt.reference_lexical_info(gc::As_assert((*closed)[i])); } if (closed->length() == 0) // don't need to actually close - ctxt.assemble1(vm_const, ctxt.cfunction_index(fun)); + ctxt.assemble1(vm_code::_const, ctxt.cfunction_index(fun)); else - ctxt.assemble1(vm_make_closure, ctxt.cfunction_index(fun)); + ctxt.assemble1(vm_code::make_closure, ctxt.cfunction_index(fun)); } else { // ought to be a function name FunInfoV info = fun_info_v(fnameoid, env); if (std::holds_alternative(info) || std::holds_alternative(info)) { if (std::holds_alternative(info) // Warn && _sym_register_global_function_ref->fboundp() && !code_walking_p()) eval::funcall(_sym_register_global_function_ref, fnameoid, ctxt.source_info()); - ctxt.assemble1(vm_fdefinition, ctxt.fcell_index(fnameoid)); + ctxt.assemble1(vm_code::fdefinition, ctxt.fcell_index(fnameoid)); } else if (std::holds_alternative(info)) { LocalFunInfo_sp lfinfo = std::get(info).info(); lfinfo->lex()->setReadP(true); @@ -2040,7 +2034,7 @@ void compile_function(T_sp fnameoid, Lexenv_sp env, const Context ctxt) { } // Coerce to values if necessary. if (mvp) - ctxt.assemble0(vm_pop); + ctxt.assemble0(vm_code::pop); } // Compile a function designator knowing that it will be immediately @@ -2055,16 +2049,16 @@ void compile_called_function(T_sp fnameoid, Lexenv_sp env, const Context ctxt) { ctxt.reference_lexical_info(gc::As_assert((*closed)[i])); } if (closed->length() == 0) // don't need to actually close - ctxt.assemble1(vm_const, ctxt.cfunction_index(fun)); + ctxt.assemble1(vm_code::_const, ctxt.cfunction_index(fun)); else - ctxt.assemble1(vm_make_closure, ctxt.cfunction_index(fun)); + ctxt.assemble1(vm_code::make_closure, ctxt.cfunction_index(fun)); } else { // ought to be a function name FunInfoV info = fun_info_v(fnameoid, env); if (std::holds_alternative(info) || std::holds_alternative(info)) { if (std::holds_alternative(info) // Warn && _sym_register_global_function_ref->fboundp() && !code_walking_p()) eval::funcall(_sym_register_global_function_ref, fnameoid, ctxt.source_info()); - ctxt.assemble1(vm_called_fdefinition, ctxt.fcell_index(fnameoid)); + ctxt.assemble1(vm_code::called_fdefinition, ctxt.fcell_index(fnameoid)); } else if (std::holds_alternative(info)) { LocalFunInfo_sp lfinfo = std::get(info).info(); lfinfo->lex()->setReadP(true); @@ -2083,7 +2077,7 @@ void compile_fdesignator(T_sp fform, Lexenv_sp env, const Context ctxt) { // If we get (function ...) or (lambda ...), which is quite common // e.g. in (funcall #'(setf...) ...) // and (multiple-value-call (lambda ...mv-bind code ...) form) - // we don't need to emit a vm_fdesignator instruction or anything. + // we don't need to emit a vm_code::fdesignator instruction or anything. // TODO: We could do something smarter if given 'foo or a constant, // but those are more marginal. // This function basically bypasses compile_form. As such we need to @@ -2105,7 +2099,7 @@ void compile_fdesignator(T_sp fform, Lexenv_sp env, const Context ctxt) { } // default compile_form(fform, env, ctxt.sub_receiving(1)); - ctxt.assemble1(vm_fdesignator, ctxt.env_index()); + ctxt.assemble1(vm_code::fdesignator, ctxt.env_index()); } void compile_flet(List_sp definitions, List_sp body, Lexenv_sp env, const Context ctxt) { @@ -2147,8 +2141,7 @@ void compile_flet(List_sp definitions, List_sp body, Lexenv_sp env, const Contex lex->setIgnore(binding_ignore(fname, declares)); lex->setDecls(decls_for_fun(name, declares)); debugbindings << Cons_O::create(fname, lex); - ibindings << Cons_O::createList(fname, lex, - source_location_for(oCar(cur), ctxt.source_info())); + ibindings << Cons_O::createList(fname, lex, source_location_for(oCar(cur), ctxt.source_info())); } T_sp dbindings = debugbindings.cons(); if (dbindings.notnilp()) @@ -2193,18 +2186,17 @@ void compile_labels(List_sp definitions, List_sp body, Lexenv_sp env, const Cont size_t literal_index = ctxt.cfunction_index(fun); LocalFunInfo_sp lfi = gc::As_assert(fun_info(name, new_env)); if (fun->closed()->length() == 0) // not a closure- easy - ctxt.assemble1(vm_const, literal_index); + ctxt.assemble1(vm_code::_const, literal_index); else { closures << Cons_O::create(fun, clasp_make_fixnum(lfi->frameIndex())); - ctxt.assemble1(vm_make_uninitialized_closure, literal_index); + ctxt.assemble1(vm_code::make_uninitialized_closure, literal_index); } T_sp fname = Cons_O::createList(cl::_sym_Function_O, name); LexicalInfo_sp lex = lfi->lex(); lex->setIgnore(binding_ignore(fname, body_declares)); lex->setDecls(decls_for_fun(name, body_declares)); debugbindings << Cons_O::create(fname, lex); - ibindings << Cons_O::createList(fname, lex, - source_location_for(definition, ctxt.source_info())); + ibindings << Cons_O::createList(fname, lex, source_location_for(definition, ctxt.source_info())); } ctxt.emit_bind(fun_count, env->frameEnd()); T_sp dbindings = debugbindings.cons(); @@ -2219,7 +2211,7 @@ void compile_labels(List_sp definitions, List_sp body, Lexenv_sp env, const Cont LexicalInfo_sp info = gc::As_assert((*closed)[i]); ctxt.reference_lexical_info(info); } - ctxt.assemble1(vm_initialize_closure, oCdar(cur).unsafe_fixnum()); + ctxt.assemble1(vm_code::initialize_closure, oCdar(cur).unsafe_fixnum()); } compile_locally(body, new_env, ctxt); end_label->contextualize(ctxt); @@ -2242,11 +2234,11 @@ static void compile_setq_1(Symbol_sp var, T_sp valf, Lexenv_sp env, const Contex // alter it. // but if we're not returning a value we don't actually have to do that crap. if (ctxt.receiving() != 0) { - ctxt.assemble0(vm_dup); + ctxt.assemble0(vm_code::dup); } - ctxt.assemble1(vm_symbol_value_set, ctxt.vcell_index(var)); + ctxt.assemble1(vm_code::symbol_value_set, ctxt.vcell_index(var)); if (ctxt.receiving() == -1) // need values - ctxt.assemble0(vm_pop); + ctxt.assemble0(vm_code::pop); } else if (std::holds_alternative(info)) { LexicalVarInfo_sp lvinfo = std::get(info).info(); bool localp = (lvinfo->funct() == ctxt.cfunction()); @@ -2256,29 +2248,30 @@ static void compile_setq_1(Symbol_sp var, T_sp valf, Lexenv_sp env, const Contex compile_form(valf, env, ctxt.sub_receiving(1)); // Similar concerns to specials above (for closure variables) if (ctxt.receiving() != 0) { - ctxt.assemble0(vm_dup); + ctxt.assemble0(vm_code::dup); } if (localp) ctxt.emit_lexical_set(lvinfo); else { // we already know we need a cell, so don't bother w/ a fixup. - ctxt.assemble1(vm_closure, ctxt.closure_index(lvinfo->lex())); - ctxt.assemble0(vm_cell_set); + ctxt.assemble1(vm_code::closure, ctxt.closure_index(lvinfo->lex())); + ctxt.assemble0(vm_code::cell_set); } if (ctxt.receiving() == -1) - ctxt.assemble0(vm_pop); + ctxt.assemble0(vm_code::pop); } else if (std::holds_alternative(info)) { // FIXME: Better error (warning?) SIMPLE_ERROR("Cannot modify constant {}", var->__repr__()); - } else UNREACHABLE(); + } else + UNREACHABLE(); } void compile_setq(List_sp pairs, Lexenv_sp env, const Context ctxt) { if (pairs.nilp()) { // degenerate case if (ctxt.receiving() != 0) { - ctxt.assemble0(vm_nil); + ctxt.assemble0(vm_code::nil); if (ctxt.receiving() == -1) - ctxt.assemble0(vm_pop); + ctxt.assemble0(vm_code::pop); } } else { do { @@ -2318,8 +2311,7 @@ void compile_the(T_sp type, T_sp form, Lexenv_sp env, const Context ctxt) { void compile_if(T_sp cond, T_sp thn, T_sp els, Lexenv_sp env, const Context ctxt) { compile_form(cond, env, ctxt.sub_receiving(1)); - Label_sp then_label = Label_O::make(), - else_label = Label_O::make(); + Label_sp then_label = Label_O::make(), else_label = Label_O::make(); Label_sp done_label = Label_O::make(); ctxt.emit_jump_if(then_label); else_label->contextualize(ctxt); @@ -2380,9 +2372,9 @@ void compile_tagbody(List_sp statements, Lexenv_sp env, const Context ctxt) { } // return nil if we really have to if (ctxt.receiving() != 0) { - ctxt.assemble0(vm_nil); + ctxt.assemble0(vm_code::nil); if (ctxt.receiving() == -1) - ctxt.assemble0(vm_pop); + ctxt.assemble0(vm_code::pop); } } @@ -2396,9 +2388,9 @@ static void compile_exit(LexicalInfo_sp exit_de, Label_sp exit, const Context co if (gc::IsA(interde)) context.maybe_emit_entry_close(gc::As_unsafe(interde)); else if (interde == cl::_sym_catch) - context.assemble0(vm_catch_close); + context.assemble0(vm_code::catch_close); else if (interde == cl::_sym_unwind_protect) - context.assemble0(vm_cleanup); + context.assemble0(vm_code::cleanup); else // must be a count of specials context.emit_unbind(interde.unsafe_fixnum()); } @@ -2440,7 +2432,7 @@ void compile_block(Symbol_sp name, List_sp body, Lexenv_sp env, const Context ct // If we're returning multiple values, the local and nonlocal returns just // store into the multiple values, so no problem there. // If we're returning exactly one value, the local just pushes one, and - // the nonlocal stores into the MV which is then vm_push'd to the stack. + // the nonlocal stores into the MV which is then vm_code::push'd to the stack. bool r1p = ctxt.receiving() == 1; compile_progn(body, nenv, ctxt.sub_de(blex)); if (r1p) @@ -2449,7 +2441,7 @@ void compile_block(Symbol_sp name, List_sp body, Lexenv_sp env, const Context ct // When we need 1 value, we have to make sure that the // "exceptional" case pushes a single value onto the stack. if (r1p) { - ctxt.assemble0(vm_push); + ctxt.assemble0(vm_code::push); normal_label->contextualize(ctxt); } ctxt.maybe_emit_entry_close(blex); @@ -2482,12 +2474,12 @@ void compile_catch(T_sp tag, List_sp body, Lexenv_sp env, const Context ctxt) { start->contextualize(ctxt); ctxt.push_debug_info(BytecodeAstBlock_O::make(start, target, cl::_sym_catch, ctxt.receiving())); compile_progn(body, env, ctxt.sub_de(cl::_sym_catch)); - ctxt.assemble0(vm_catch_close); + ctxt.assemble0(vm_code::catch_close); if (r1p) ctxt.emit_jump(normal_label); target->contextualize(ctxt); if (r1p) { - ctxt.assemble0(vm_push); + ctxt.assemble0(vm_code::push); normal_label->contextualize(ctxt); } } @@ -2495,32 +2487,32 @@ void compile_catch(T_sp tag, List_sp body, Lexenv_sp env, const Context ctxt) { void compile_throw(T_sp tag, T_sp rform, Lexenv_sp env, const Context ctxt) { compile_form(tag, env, ctxt.sub_receiving(1)); compile_form(rform, env, ctxt.sub_receiving(-1)); - ctxt.assemble0(vm_throw); + ctxt.assemble0(vm_code::_throw); } -void compile_unwind_protect(T_sp protect, List_sp cleanup, - Lexenv_sp env, const Context ctxt) { +void compile_unwind_protect(T_sp protect, List_sp cleanup, Lexenv_sp env, const Context ctxt) { if (cleanup.nilp()) { // trivial compile_form(protect, env, ctxt); } else { // Make the cleanup closure. // Duplicates a bit of code from compile_function. - Cfunction_sp cleanupt = compile_lambda(nil(), Cons_O::createList(Cons_O::create(cl::_sym_progn, cleanup)), env, ctxt.module(), ctxt.source_info()); + Cfunction_sp cleanupt = compile_lambda(nil(), Cons_O::createList(Cons_O::create(cl::_sym_progn, cleanup)), env, + ctxt.module(), ctxt.source_info()); ComplexVector_T_sp closed = cleanupt->closed(); for (size_t i = 0; i < closed->length(); ++i) ctxt.reference_lexical_info((*closed)[i].as_assert()); // Actual protect instruction - ctxt.assemble1(vm_protect, ctxt.cfunction_index(cleanupt)); + ctxt.assemble1(vm_code::protect, ctxt.cfunction_index(cleanupt)); // and the body... compile_form(protect, env, ctxt.sub_de(cl::_sym_unwind_protect)); - ctxt.assemble0(vm_cleanup); + ctxt.assemble0(vm_code::cleanup); } } void compile_progv(T_sp syms, T_sp vals, List_sp body, Lexenv_sp env, const Context ctxt) { compile_form(syms, env, ctxt.sub_receiving(1)); compile_form(vals, env, ctxt.sub_receiving(1)); - ctxt.assemble1(vm_progv, ctxt.env_index()); + ctxt.assemble1(vm_code::progv, ctxt.env_index()); compile_progn(body, env, ctxt.sub_de(clasp_make_fixnum(1))); ctxt.emit_unbind(1); } @@ -2534,11 +2526,11 @@ void compile_multiple_value_call(T_sp fform, List_sp aforms, Lexenv_sp env, cons T_sp first = oCar(aforms); List_sp rest = gc::As(oCdr(aforms)); compile_form(first, env, ctxt.sub_receiving(-1)); - ctxt.assemble0(vm_push_values); + ctxt.assemble0(vm_code::push_values); if (rest.notnilp()) { for (auto cur : rest) { compile_form(oCar(cur), env, ctxt.sub_receiving(-1)); - ctxt.assemble0(vm_append_values); + ctxt.assemble0(vm_code::append_values); } } ctxt.emit_mv_call(); @@ -2549,11 +2541,11 @@ void compile_multiple_value_prog1(T_sp fform, List_sp forms, Lexenv_sp env, cons compile_form(fform, env, ctxt); // We only need to actually save anything with all-values returns. if (ctxt.receiving() == -1) - ctxt.assemble0(vm_push_values); + ctxt.assemble0(vm_code::push_values); for (auto cur : forms) compile_form(oCar(cur), env, ctxt.sub_receiving(0)); if (ctxt.receiving() == -1) - ctxt.assemble0(vm_pop_values); + ctxt.assemble0(vm_code::pop_values); } // Compile a call, where the function is already on the stack. @@ -2596,11 +2588,11 @@ void compile_load_time_value(T_sp form, T_sp tread_only_p, Lexenv_sp env, const case 0: break; // no value required, so compile nothing case 1: - context.assemble1(vm_const, ind); + context.assemble1(vm_code::_const, ind); break; case -1: // all values - context.assemble1(vm_const, ind); - context.assemble0(vm_pop); + context.assemble1(vm_code::_const, ind); + context.assemble0(vm_code::pop); break; default: SIMPLE_ERROR("BUG: Don't know how to compile LTV returning %" PFixnum " values", context.receiving()); diff --git a/src/core/commonLispPackage.cc b/src/core/commonLispPackage.cc index c99743b7f3..660d093fb3 100644 --- a/src/core/commonLispPackage.cc +++ b/src/core/commonLispPackage.cc @@ -222,6 +222,7 @@ SYMBOL_EXPORT_SC_(ClPkg, listp); SYMBOL_EXPORT_SC_(ClPkg, load); SYMBOL_EXPORT_SC_(ClPkg, logicalPathnameTranslations); SYMBOL_EXPORT_SC_(ClPkg, logical_pathname); +SYMBOL_EXPORT_SC_(ClPkg, long_float); SYMBOL_EXPORT_SC_(ClPkg, makeArray); SYMBOL_EXPORT_SC_(ClPkg, makeCondition); SYMBOL_EXPORT_SC_(ClPkg, makePathname); @@ -279,6 +280,7 @@ SYMBOL_EXPORT_SC_(ClPkg, schar); SYMBOL_EXPORT_SC_(ClPkg, sequence); SYMBOL_EXPORT_SC_(ClPkg, seriousCondition); SYMBOL_EXPORT_SC_(ClPkg, set); +SYMBOL_EXPORT_SC_(ClPkg, short_float); SYMBOL_EXPORT_SC_(ClPkg, simpleCondition); SYMBOL_EXPORT_SC_(ClPkg, simpleError); SYMBOL_EXPORT_SC_(ClPkg, simpleTypeError); diff --git a/src/core/compiler.cc b/src/core/compiler.cc index c1b2601724..c80aed9bf5 100644 --- a/src/core/compiler.cc +++ b/src/core/compiler.cc @@ -75,6 +75,8 @@ THE SOFTWARE. #include #include // funwind_protect +#define FASO_VERSION 1 + namespace core { std::atomic global_jit_compile_counter; @@ -532,7 +534,7 @@ void setup_FasoHeader(FasoHeader* header) { header->_Magic[1] = FASO_MAGIC_NUMBER_1; header->_Magic[2] = FASO_MAGIC_NUMBER_2; header->_Magic[3] = FASO_MAGIC_NUMBER_3; - header->_Version = 0; + header->_Version = FASO_VERSION; header->_PageSize = getpagesize(); } @@ -643,8 +645,13 @@ CL_DEFUN void core__link_faso_files(T_sp outputPathDesig, List_sp fasoFiles, boo } close(fd); FasoHeader* header = (FasoHeader*)memory; - if (header->_Magic[0] == FASO_MAGIC_NUMBER_0 && header->_Magic[1] == FASO_MAGIC_NUMBER_1 && - header->_Magic[2] == FASO_MAGIC_NUMBER_2 && header->_Magic[3] == FASO_MAGIC_NUMBER_3) { + if (header->_Magic[0] != FASO_MAGIC_NUMBER_0 || header->_Magic[1] != FASO_MAGIC_NUMBER_1 || + header->_Magic[2] != FASO_MAGIC_NUMBER_2 || header->_Magic[3] != FASO_MAGIC_NUMBER_3) { + SIMPLE_ERROR("Illegal and unknown file type - magic number: %X%X%X%X\n", (uint8_t)header->_Magic[0], + (uint8_t)header->_Magic[1], (uint8_t)header->_Magic[2], (uint8_t)header->_Magic[3]); + } else if (header->_Version != FASO_VERSION) { + SIMPLE_ERROR("FASO version {:04x} is not readable by this loader", header->_Version); + } else { size_t object0_offset = (header->_HeaderPageCount * header->_PageSize); if (verbose) clasp_write_string( @@ -660,9 +667,6 @@ CL_DEFUN void core__link_faso_files(T_sp outputPathDesig, List_sp fasoFiles, boo if (verbose) clasp_write_string(fmt::format("allObjectFiles.size() = {}\n", allObjectFiles.size())); } - } else { - SIMPLE_ERROR("Illegal and unknown file type - magic number: %X%X%X%X\n", (uint8_t)header->_Magic[0], - (uint8_t)header->_Magic[1], (uint8_t)header->_Magic[2], (uint8_t)header->_Magic[3]); } } FasoHeader* header = (FasoHeader*)malloc(FasoHeader::calculateSize(allObjectFiles.size())); @@ -767,6 +771,8 @@ CL_DEFUN core::T_sp core__load_faso(T_sp pathDesig, T_sp verbose, T_sp print, T_ close(fd); // Ok to close file descriptor after mmap llvmo::ClaspJIT_sp jit = gc::As(_lisp->_Roots._ClaspJIT); FasoHeader* header = (FasoHeader*)memory; + if (header->_Version != FASO_VERSION) + SIMPLE_ERROR("FASO version {:04x} is not readable by this loader", header->_Version); llvmo::JITDylib_sp jitDylib; for (size_t fasoIndex = 0; fasoIndex < header->_NumberOfObjectFiles; ++fasoIndex) { if (!jitDylib || header->_ObjectFiles[fasoIndex]._ObjectId == 0) { @@ -1269,11 +1275,17 @@ SYMBOL_EXPORT_SC_(CorePkg, callWithVariableBound); template char document() { return '\0'; }; template <> char document() { return 'c'; }; -template <> char document() { return 's'; }; +template <> char document() { return 'z'; }; template <> char document() { return 'S'; }; template <> char document() { return 'O'; }; +#ifdef CLASP_SHORT_FLOAT +template <> char document() { return 's'; }; +#endif template <> char document() { return 'f'; }; template <> char document() { return 'd'; }; +#ifdef CLASP_LONG_FLOAT +template <> char document() { return 'l'; }; +#endif template <> char document() { return 'f'; }; char ll_read_char(T_sp stream, bool log, size_t& index) { @@ -1433,6 +1445,39 @@ T_O* ltvc_read_bignum(char*& bytecode, char* byteend, bool log) { return reinterpret_cast(Bignum_O::create_from_limbs(length, 0, false, size, limbs).raw_()); } +#ifdef CLASP_SHORT_FLOAT +DOCGROUP(clasp); +CL_DEFUN size_t core__ltvc_write_short_float(T_sp object, T_sp stream, size_t index) { + SELF_DOCUMENT(long_short_t, stream, index); + uint16_t bits = float_convert::float_to_bits(object.unsafe_short_float()); + clasp_write_characters((char*)bits, 2, stream); + index += 2; + return index; + + clasp_write_characters((char*)&data, sizeof(data), stream); + index += sizeof(data); + return index; +} +#endif + +short_float_t ltvc_read_binary16(char*& bytecode, char* byteend, bool log) { + SELF_CHECK(short_float_t, stream, index); + using convert = float_convert; + uint16_t bits = 0; + if (bytecode > byteend - 2) + SIMPLE_ERROR("Unexpected EOF"); + for (size_t i = 0; i < 2; ++i) { + ((char*)&bits)[i] = *bytecode++; + } + if (log) + fmt::print("{}:{}:{} -> '{}'\n", __FILE__, __LINE__, __FUNCTION__, bits); +#ifdef CLASP_SHORT_FLOAT_BINARY16 + return convert::bits_to_float(bits); +#else + return convert::quadruple_to_float(convert::bits_to_quadruple>(bits)); +#endif +} + DOCGROUP(clasp); CL_DEFUN size_t core__ltvc_write_float(T_sp object, T_sp stream, size_t index) { SELF_DOCUMENT(float, stream, index); @@ -1481,6 +1526,58 @@ double ltvc_read_double(char*& bytecode, char* byteend, bool log) { return data; } +#ifdef CLASP_LONG_FLOAT +DOCGROUP(clasp); +CL_DEFUN size_t core__ltvc_write_long_float(T_sp object, T_sp stream, size_t index) { + SELF_DOCUMENT(long_float_t, stream, index); +#ifdef CLASP_LONG_FLOAT_BINARY80 + constexpr size_t width = 10; +#else + constexpr size_t width = 16; +#endif + unsigned _BitInt(width * 8) bits = float_convert::float_to_bits(gc::As(object)->get()); + clasp_write_characters((char*)&bits, width, stream); + index += width; + return index; +} +#endif + +long_float_t ltvc_read_binary80(char*& bytecode, char* byteend, bool log) { + SELF_CHECK(long_float_t, stream, index); + using convert = float_convert; + unsigned _BitInt(80) bits = 0; + if (bytecode > byteend - 10) + SIMPLE_ERROR("Unexpected EOF"); + for (size_t i = 0; i < 10; ++i) { + ((char*)&bits)[i] = *bytecode++; + } + if (log) + fmt::print("{}:{}:{} -> '{}'\n", __FILE__, __LINE__, __FUNCTION__, (__uint128_t)bits); +#ifdef CLASP_LONG_FLOAT_BINARY80 + return convert::bits_to_float(bits); +#else + return convert::quadruple_to_float(convert::bits_to_quadruple>(bits)); +#endif +} + +long_float_t ltvc_read_binary128(char*& bytecode, char* byteend, bool log) { + SELF_CHECK(long_float_t, stream, index); + using convert = float_convert; + unsigned _BitInt(128) bits = 0; + if (bytecode > byteend - 16) + SIMPLE_ERROR("Unexpected EOF"); + for (size_t i = 0; i < 16; ++i) { + ((char*)&bits)[i] = *bytecode++; + } + if (log) + fmt::print("{}:{}:{} -> '{}'\n", __FILE__, __LINE__, __FUNCTION__, (__uint128_t)bits); +#ifdef CLASP_LONG_FLOAT_BINARY128 + return convert::bits_to_float(bits); +#else + return convert::quadruple_to_float(convert::bits_to_quadruple>(bits)); +#endif +} + CL_DOCSTRING(R"dx(tag is (0|1|2) where 0==literal, 1==transient, 2==immediate)dx"); DOCGROUP(clasp); CL_DEFUN size_t core__ltvc_write_object(T_sp ttag, T_sp index_or_immediate, T_sp stream, size_t index) { @@ -1634,7 +1731,7 @@ void start_code_interpreter(gctools::GCRootsInModule* roots, char* bytecode, siz fasoFile = objectFile->_FasoName->get_std_string(); fasoIndex = objectFile->_FasoIndex; } - SIMPLE_ERROR("While loading the faso file {} {} an illegal byte-code %d was detected. This usually happens when a faso file " + SIMPLE_ERROR("While loading the faso file {} {} an illegal byte-code {} was detected. This usually happens when a faso file " "is out of date and the byte code has changed in the meantime.", fasoFile, fasoIndex, (int)c); } diff --git a/src/core/corePackage.cc b/src/core/corePackage.cc index 46a0f42f85..d4731cc314 100644 --- a/src/core/corePackage.cc +++ b/src/core/corePackage.cc @@ -835,6 +835,21 @@ void CoreExposer_O::define_essential_globals(LispPtr lisp) { #endif #ifdef DEFAULT_OUTPUT_TYPE_BYTECODE features = Cons_O::create(_lisp->internKeyword("BYTECODE"), features); +#endif +#ifdef CLASP_SHORT_FLOAT + features = Cons_O::create(_lisp->internKeyword("SHORT-FLOAT"), features); +#endif +#ifdef CLASP_SHORT_FLOAT_BINARY16 + features = Cons_O::create(_lisp->internKeyword("SHORT-FLOAT/BINARY16"), features); +#endif +#ifdef CLASP_LONG_FLOAT + features = Cons_O::create(_lisp->internKeyword("LONG-FLOAT"), features); +#endif +#ifdef CLASP_LONG_FLOAT_BINARY80 + features = Cons_O::create(_lisp->internKeyword("LONG-FLOAT/BINARY80"), features); +#endif +#ifdef CLASP_LONG_FLOAT_BINARY128 + features = Cons_O::create(_lisp->internKeyword("LONG-FLOAT/BINARY128"), features); #endif cl::_sym_STARfeaturesSTAR->exportYourself()->defparameter(features); } diff --git a/src/core/float_to_digits.cc b/src/core/float_to_digits.cc index 2ef494b3a4..b123d97cda 100644 --- a/src/core/float_to_digits.cc +++ b/src/core/float_to_digits.cc @@ -38,13 +38,13 @@ THE SOFTWARE. namespace core { template T_mv float_to_digits(T_sp tdigits, Float number, T_sp round_position, T_sp relativep) { - StrNs_sp digits = tdigits.nilp() ? gc::As(core__make_vector(cl::_sym_base_char, 10, true, clasp_make_fixnum(0))) - : gc::As(tdigits); - + const char* num_to_text = "0123456789"; schubfach::decimal_float decimal = number; auto digit_count = decimal.math.count_digits(decimal.significand); auto position = decimal.exponent + digit_count; + StrNs_sp digits; + if (round_position.notnilp()) { int pos = gc::As(round_position).unsafe_fixnum(); pos = relativep.nilp() ? (position - pos) : (pos + 1); @@ -57,13 +57,35 @@ template T_mv float_to_digits(T_sp tdigits, Float number, T_sp if (pos < digit_count) { decltype(decimal.significand) divisor = std::pow(10, digit_count - pos); decimal.significand = (decimal.significand + (divisor / 2)) / divisor; + digit_count = decimal.math.count_digits(decimal.significand); } } - for (auto ch : std::to_string(decimal.significand)) - digits->vectorPushExtend(clasp_make_character(ch), 64); + if (decimal.significand == 0) + position = 0; + + if (tdigits.nilp()) { + digits = gc::As(core__make_vector(cl::_sym_base_char, digit_count, true, clasp_make_fixnum(digit_count))); + } else { + digits = gc::As(tdigits); + digits->resize(digit_count); + } - return Values(clasp_make_fixnum((decimal.significand == 0) ? 0 : position), digits); + if (Str8Ns_sp buffer8 = digits.asOrNull()) { + for (size_t i = 0; i < digit_count; i++) { + auto rem = decimal.significand % 10u; + decimal.significand /= 10u; + (*buffer8)[digit_count - i - 1] = num_to_text[rem]; + } + } else if (StrWNs_sp bufferw = digits.asOrNull()) { + for (size_t i = 0; i < digit_count; i++) { + auto rem = decimal.significand % 10u; + decimal.significand /= 10u; + (*bufferw)[digit_count - i - 1] = num_to_text[rem]; + } + } + + return Values(clasp_make_fixnum(position), digits); } CL_LAMBDA(digits number position relativep); @@ -72,20 +94,19 @@ CL_DOCSTRING(R"dx(float_to_digits)dx"); DOCGROUP(clasp); CL_DEFUN T_mv core__float_to_digits(T_sp tdigits, Float_sp number, T_sp position, T_sp relativep) { ASSERT(tdigits.nilp() || gc::IsA(tdigits)); - - switch (clasp_t_of(number)) { - case number_SingleFloat: - return float_to_digits(tdigits, unbox_single_float(gc::As(number)), position, relativep); - case number_DoubleFloat: - return float_to_digits(tdigits, gc::As(number)->get(), position, relativep); - break; #ifdef CLASP_LONG_FLOAT - case number_LongFloat: - return float_to_digits(tdigits, gc::As(number)->get(), position, relativep); + if (number.isA()) + return float_to_digits(tdigits, number.as_unsafe()->get(), position, relativep); #endif - default: - SIMPLE_ERROR("Illegal type"); - } + if (number.isA()) + return float_to_digits(tdigits, number.as_unsafe()->get(), position, relativep); + if (number.single_floatp()) + return float_to_digits(tdigits, number.unsafe_single_float(), position, relativep); +#ifdef CLASP_SHORT_FLOAT + if (number.short_floatp()) + return float_to_digits(tdigits, number.unsafe_short_float(), position, relativep); +#endif + SIMPLE_ERROR("Illegal type"); } SYMBOL_EXPORT_SC_(CorePkg, float_to_digits); diff --git a/src/core/float_to_string.cc b/src/core/float_to_string.cc index e853a5067e..5254745412 100644 --- a/src/core/float_to_string.cc +++ b/src/core/float_to_string.cc @@ -55,32 +55,27 @@ static void insert_char(StrNs_sp buffer, cl_index where, gc::Fixnum c) { * FREE FORMAT (FIXED OR EXPONENT) OF FLOATS */ -static void print_float_exponent(T_sp buffer, T_sp number, gc::Fixnum exp) { +static void print_float_exponent(T_sp buffer, Float_sp number, gc::Fixnum exp) { T_sp r = cl::_sym_STARreadDefaultFloatFormatSTAR->symbolValue(); - gc::Fixnum e; - switch (clasp_t_of(gc::As(number))) { - case number_SingleFloat: - e = (r == cl::_sym_single_float || r == cl::_sym_ShortFloat_O) ? 'e' : 'f'; - break; - case number_ShortFloat: - e = (r == cl::_sym_single_float || r == cl::_sym_ShortFloat_O) ? 'e' : 'f'; - break; -#ifdef ECL_LONG_FLOAT - case number_LongFloat: - e = (r == @'long-float') ? 'e' : 'l'; - break; - case number_DoubleFloat: - e = (r == @'double-float') ? 'e' : 'd'; - break; + char e = 'e'; +#ifdef CLASP_SHORT_FLOAT + if (number.short_floatp()) + e = (r == cl::_sym_short_float) ? 'e' : 's'; + else if (number.single_floatp()) + e = (r == cl::_sym_single_float) ? 'e' : 'f'; #else - case number_DoubleFloat: - e = (r == cl::_sym_DoubleFloat_O || r == cl::_sym_LongFloat_O) ? 'e' : 'd'; - break; + if (number.single_floatp()) + e = (r == cl::_sym_single_float || r == cl::_sym_short_float) ? 'e' : 'f'; +#endif +#ifdef CLASP_LONG_FLOAT + else if (number.isA()) + e = (r == cl::_sym_double_float) ? 'e' : 'd'; + else if (number.isA()) + e = (r == cl::_sym_long_float) ? 'e' : 'l'; +#else + else if (number.isA()) + e = (r == cl::_sym_double_float || r == cl::_sym_long_float) ? 'e' : 'd'; #endif - default: - SIMPLE_ERROR("Handle additional enumeration values value={} t_of={}", _rep_(number).c_str(), - clasp_t_of(gc::As(number))); - } if (e != 'e' || exp != 0) { StrNs_sp sbuffer = gc::As(buffer); sbuffer->vectorPushExtend(clasp_make_character(e)); @@ -90,9 +85,9 @@ static void print_float_exponent(T_sp buffer, T_sp number, gc::Fixnum exp) { T_sp core_float_to_string_free(Float_sp number, Number_sp e_min, Number_sp e_max) { gc::Fixnum base = 0, e; - if (clasp_float_nan_p(number)) { + if (Float_O::isnan(number)) { return eval::funcall(ext::_sym_float_nan_string, number); - } else if (clasp_float_infinity_p(number)) { + } else if (Float_O::isinf(number)) { return eval::funcall(ext::_sym_float_infinity_string, number); } T_mv mv_exp = core__float_to_digits(nil(), number, nil(), nil()); @@ -104,7 +99,7 @@ T_sp core_float_to_string_free(Float_sp number, Number_sp e_min, Number_sp e_max insert_char(buffer, base++, '-'); } /* Do we have to print in exponent notation? */ - if (clasp_lowereq(exp, e_min) || clasp_lowereq(e_max, exp)) { + if (clasp_lowereq(exp, e_min.as()) || clasp_lowereq(e_max.as(), exp)) { insert_char(buffer, base + 1, '.'); if (gc::As(buffer)->fillPointer() == base + 2) buffer->vectorPushExtend(clasp_make_character('0')); diff --git a/src/core/hashTable.cc b/src/core/hashTable.cc index 1872bfae42..fbb335f9ca 100644 --- a/src/core/hashTable.cc +++ b/src/core/hashTable.cc @@ -455,7 +455,7 @@ DOCGROUP(clasp); CL_DEFUN bool cl__remhash(T_sp key, HashTableBase_sp ht) { return ht->remhash(key); }; T_sp HashTable_O::clrhash() { - ASSERT(!clasp_zerop(this->_RehashSize)); + ASSERT(!Number_O::zerop(this->_RehashSize)); this->_HashTableCount = 0; T_sp no_key = ::no_key(); this->_Table.resize(0, KeyValuePair(no_key, no_key)); @@ -473,7 +473,7 @@ void HashTable_O::setup(uint sz, Number_sp rehashSize, double rehashThreshold) { HT_WRITE_LOCK(this); sz = this->resizeEmptyTable_no_lock(sz); this->_RehashSize = rehashSize; - ASSERT(!clasp_zerop(this->_RehashSize)); + ASSERT(!Number_O::zerop(this->_RehashSize)); this->_RehashThreshold = maybeFixRehashThreshold(rehashThreshold); } @@ -515,7 +515,7 @@ void HashTable_O::sxhash_eql(HashGenerator& hg, T_sp obj) { return; } case gctools::single_float_tag: { - hg.addValue0(float_convert::to_bits(obj.unsafe_single_float())); + hg.addValue0(float_convert::float_to_bits(obj.unsafe_single_float())); return; } case gctools::character_tag: { @@ -547,7 +547,7 @@ void HashTable_O::sxhash_eql(Hash1Generator& hg, T_sp obj) { return; } else if (obj.single_floatp()) { if (hg.isFilling()) { - hg.addValue(float_convert::to_bits(obj.unsafe_single_float())); + hg.addValue(float_convert::float_to_bits(obj.unsafe_single_float())); } return; } else if (obj.characterp()) { @@ -575,7 +575,7 @@ void HashTable_O::sxhash_equal(HashGenerator& hg, T_sp obj) { return; } else if (obj.single_floatp()) { if (hg.isFilling()) { - hg.addValue(float_convert::to_bits(obj.unsafe_single_float())); + hg.addValue(float_convert::float_to_bits(obj.unsafe_single_float())); } return; } else if (obj.characterp()) { @@ -617,7 +617,7 @@ void HashTable_O::sxhash_equalp(HashGenerator& hg, T_sp obj) { } else if (obj.single_floatp()) { if (hg.isFilling()) { float value = obj.unsafe_single_float(); - hg.addValue((std::fpclassify(value) == FP_ZERO) ? 0u : float_convert::to_bits(value)); + hg.addValue((std::fpclassify(value) == FP_ZERO) ? 0u : float_convert::float_to_bits(value)); } return; } else if (obj.characterp()) { @@ -1033,7 +1033,7 @@ CL_DEFUN_SETF T_sp setf_gethash(T_sp value, T_sp key, HashTableBase_sp hash_tabl KeyValuePair* HashTable_O::rehash_no_lock(bool expandTable, T_sp findKey) { // printf("%s:%d rehash of hash-table@%p\n", __FILE__, __LINE__, this ); DEBUG_HASH_TABLE1({ core::clasp_write_string(fmt::format("{}:{} rehash_no_lock\n", __FILE__, __LINE__)); }); - ASSERTF(!clasp_zerop(this->_RehashSize), "RehashSize is zero - it shouldn't be"); + ASSERTF(!Number_O::zerop(this->_RehashSize), "RehashSize is zero - it shouldn't be"); #ifdef DEBUG_HASH_TABLE_DEBUG if (this->_Debug) { core::T_sp info = Cons_O::createList(INTERN_(kw, rehash), findKey); diff --git a/src/core/lispList.cc b/src/core/lispList.cc index 2d22a3e26f..d287257b78 100644 --- a/src/core/lispList.cc +++ b/src/core/lispList.cc @@ -175,7 +175,7 @@ CL_DEFUN T_sp cl__nth(Integer_sp idx, List_sp arg) { else return arg.unsafe_cons()->onth(n); } else { // index is a bignum, i.e. out of range - if (clasp_plusp(idx)) + if (Real_O::plusp(idx)) return nil(); else TYPE_ERROR(idx, cl::_sym_UnsignedByte); @@ -200,7 +200,7 @@ CL_DEFUN T_sp cl__nthcdr(Integer_sp idx, List_sp arg) { else return arg.unsafe_cons()->onthcdr(n); } else { // bignum, out of range - if (clasp_plusp(idx)) + if (Real_O::plusp(idx)) return nil(); else TYPE_ERROR(idx, cl::_sym_UnsignedByte); @@ -259,7 +259,7 @@ CL_DEFUN List_sp cl__butlast(List_sp ll, Integer_sp in) { return head; } } else { // must be a bignum - if (clasp_plusp(in)) + if (Real_O::plusp(in)) return nil(); else TYPE_ERROR(in, cl::_sym_UnsignedByte); @@ -296,7 +296,7 @@ CL_DEFUN List_sp cl__nbutlast(List_sp l, Integer_sp in) { return nil(); } else { // if it is a positive bignum, return nil - if (clasp_plusp(in)) + if (Real_O::plusp(in)) return nil(); else // negative bignum @@ -353,7 +353,7 @@ CL_DEFUN T_sp cl__last(List_sp list, Integer_sp in) { return clist->last(n); TYPE_ERROR(list, cl::_sym_list); } else { // must be a bignum - if (clasp_plusp(in)) + if (Real_O::plusp(in)) return list; else TYPE_ERROR(in, cl::_sym_UnsignedByte); diff --git a/src/core/lispReader.cc b/src/core/lispReader.cc index 1ff7e1fabb..08b5eb69ce 100644 --- a/src/core/lispReader.cc +++ b/src/core/lispReader.cc @@ -877,17 +877,17 @@ T_sp interpret_token_or_throw_reader_error(T_sp sin, Token& token, bool only_dot string numstr = tokenStr(sin, token, start - token.data())->get_std_string(); float f = ::strtof(numstr.c_str(), &lastValid); return clasp_make_single_float(f); - } else if (cl::_sym_STARreadDefaultFloatFormatSTAR->symbolValue() == cl::_sym_DoubleFloat_O) { + } else if (cl::_sym_STARreadDefaultFloatFormatSTAR->symbolValue() == cl::_sym_double_float) { string numstr = tokenStr(sin, token, start - token.data())->get_std_string(); double d = ::strtod(numstr.c_str(), &lastValid); return DoubleFloat_O::create(d); - } else if (cl::_sym_STARreadDefaultFloatFormatSTAR->symbolValue() == cl::_sym_ShortFloat_O) { + } else if (cl::_sym_STARreadDefaultFloatFormatSTAR->symbolValue() == cl::_sym_short_float) { string numstr = tokenStr(sin, token, start - token.data())->get_std_string(); float f = ::strtof(numstr.c_str(), &lastValid); return clasp_make_single_float(f); // ShortFloat_O::create(f) crashes - } else if (cl::_sym_STARreadDefaultFloatFormatSTAR->symbolValue() == cl::_sym_LongFloat_O) { + } else if (cl::_sym_STARreadDefaultFloatFormatSTAR->symbolValue() == cl::_sym_long_float) { string numstr = tokenStr(sin, token, start - token.data())->get_std_string(); - LongFloat l = ::strtod(numstr.c_str(), &lastValid); + long_float_t l = ::strtod(numstr.c_str(), &lastValid); return LongFloat_O::create(l); } else { SIMPLE_ERROR("Handle *read-default-float-format* of {}", _rep_(cl::_sym_STARreadDefaultFloatFormatSTAR->symbolValue())); @@ -903,7 +903,7 @@ T_sp interpret_token_or_throw_reader_error(T_sp sin, Token& token, bool only_dot char* lastValid = NULL; string numstr = fix_exponent_char(tokenStr(sin, token, start - token.data())->get_std_string().c_str()); double d = ::strtod(numstr.c_str(), &lastValid); - return clasp_make_single_float(d); + return ShortFloat_O::create(d); } case single_float_exp: { char* lastValid = NULL; @@ -921,7 +921,7 @@ T_sp interpret_token_or_throw_reader_error(T_sp sin, Token& token, bool only_dot char* lastValid = NULL; string numstr = fix_exponent_char(tokenStr(sin, token, start - token.data())->get_std_string().c_str()); #ifdef CLASP_LONG_FLOAT - LongFloat d = ::strtold(numstr.c_str(), &lastValid); + long_float_t d = ::strtold(numstr.c_str(), &lastValid); return LongFloat_O::create(d); #else double d = ::strtod(numstr.c_str(), &lastValid); diff --git a/src/core/lispStream.cc b/src/core/lispStream.cc index 3b0539fe11..2f5ad95e50 100644 --- a/src/core/lispStream.cc +++ b/src/core/lispStream.cc @@ -4384,7 +4384,7 @@ cl_index FileStream_O::read_sequence(T_sp data, cl_index start, cl_index end) { * decoders consume bytes in multiples of the byte size. */ T_sp fp = position(); if (fp.fixnump()) { - set_position(contagion_sub(gc::As_unsafe(fp), make_fixnum((buffer_end - buffer_pos) / (_byte_size / 8)))); + set_position(gc::As_unsafe(fp) - make_fixnum((buffer_end - buffer_pos) / (_byte_size / 8))); } else { SIMPLE_ERROR("clasp_file_position is not a number"); } @@ -4880,7 +4880,7 @@ T_sp PosixFileStream_O::set_position(T_sp pos) { mode = SEEK_END; } else { if (_byte_size != 8) { - pos = clasp_times(gc::As(pos), make_fixnum(_byte_size / 8)); + pos = gc::As(pos) * make_fixnum(_byte_size / 8); } disp = clasp_integer_to_off_t(pos); mode = SEEK_SET; @@ -5113,7 +5113,7 @@ T_sp CFileStream_O::set_position(T_sp pos) { mode = SEEK_END; } else { if (_byte_size != 8) { - pos = clasp_times(gc::As(pos), make_fixnum(_byte_size / 8)); + pos = gc::As(pos) * make_fixnum(_byte_size / 8); } disp = clasp_integer_to_off_t(pos); mode = SEEK_SET; diff --git a/src/core/loadltv.cc b/src/core/loadltv.cc index c99aca0725..c139763bed 100644 --- a/src/core/loadltv.cc +++ b/src/core/loadltv.cc @@ -8,75 +8,33 @@ #include #include #include -#include // ql::list -#include // core__ensure_function_cell -#include // modules, functions -#include // I/O -#include // making hash tables -#include // making bignums -#include // making packages -#include // making pathnames -#include // cl__truename -#include // cmp__compile_trampoline -#include // native module stuff +#include // ql::list +#include // core__ensure_function_cell +#include // modules, functions +#include // I/O +#include // making hash tables +#include // making bignums +#include // making packages +#include // making pathnames +#include // cl__truename +#include // cmp__compile_trampoline +#include // native module stuff #include #include #include // stream_read_byte8 #include // btb_bcfun_p #include // eval::funcall -// FIXME: Move these to the generated file thingie -#define LTV_OP_NIL 65 -#define LTV_OP_T 66 -#define LTV_OP_CONS 69 -#define LTV_OP_RPLACA 70 -#define LTV_OP_RPLACD 71 -#define LTV_OP_MAKE_ARRAY 74 -#define LTV_OP_SRMA 75 -#define LTV_OP_HASHT 76 -#define LTV_OP_SHASH 77 -#define LTV_OP_SB64 78 -#define LTV_OP_PACKAGE 79 -#define LTV_OP_BIGNUM 80 -#define LTV_OP_FLOAT 90 -#define LTV_OP_DOUBLE 91 -#define LTV_OP_RATIO 67 -#define LTV_OP_COMPLEX 68 -#define LTV_OP_SYMBOL 81 -#define LTV_OP_INTERN 82 -#define LTV_OP_CHARACTER 83 -#define LTV_OP_PATHNAME 85 -#define LTV_OP_BCFUNC 87 -#define LTV_OP_BCMOD 88 -#define LTV_OP_SLITS 89 -#define LTV_OP_CREATE 93 -#define LTV_OP_INIT 94 -#define LTV_OP_FDEF 95 -#define LTV_OP_FCELL 96 -#define LTV_OP_VCELL 97 -#define LTV_OP_CLASS 98 -#define LTV_OP_INIT_OBJECT_ARRAY 99 -#define LTV_OP_ENVIRONMENT 100 -#define LTV_OP_SYMBOL_VALUE 101 -#define LTV_OP_ATTR 255 - -#define LTV_DI_OP_FUNCTION 0 -#define LTV_DI_OP_VARS 1 -#define LTV_DI_OP_LOCATION 2 -#define LTV_DI_OP_DECLS 3 -#define LTV_DI_OP_THE 4 -#define LTV_DI_OP_BLOCK 5 -#define LTV_DI_OP_CATCH 6 -#define LTV_DI_OP_MACRO 7 -#define LTV_DI_OP_IF 8 -#define LTV_DI_OP_TAGBODY 9 +#define DEFINE_BYTECODE_LTV_OPS +#include +#undef DEFINE_BYTECODE_LTV_OPS namespace core { #define BC_HEADER_SIZE 16 #define BC_VERSION_MAJOR 0 -#define BC_VERSION_MINOR 14 +#define BC_VERSION_MINOR 15 // versions are std::arrays so that we can compare them. typedef std::array BCVersion; @@ -188,6 +146,26 @@ struct loadltv { return (b0 << 56) | (b1 << 48) | (b2 << 40) | (b3 << 32) | (b4 << 24) | (b5 << 16) | (b6 << 8) | (b7 << 0); } + inline __uint128_t read_u80() { + unsigned char bytes[10]; + stream_read_byte8(_stream, bytes, 10); + return (__uint128_t{bytes[0]} << 72) | (__uint128_t{bytes[1]} << 64) | (__uint128_t{bytes[2]} << 56) | + (__uint128_t{bytes[3]} << 48) | (__uint128_t{bytes[4]} << 40) | (__uint128_t{bytes[5]} << 32) | + (__uint128_t{bytes[6]} << 24) | (__uint128_t{bytes[7]} << 16) | (__uint128_t{bytes[8]} << 8) | + (__uint128_t{bytes[9]} << 0); + } + + inline __uint128_t read_u128() { + unsigned char bytes[16]; + stream_read_byte8(_stream, bytes, 16); + return (__uint128_t{bytes[0]} << 120) | (__uint128_t{bytes[1]} << 112) | (__uint128_t{bytes[2]} << 104) | + (__uint128_t{bytes[3]} << 96) | (__uint128_t{bytes[4]} << 88) | (__uint128_t{bytes[5]} << 80) | + (__uint128_t{bytes[6]} << 72) | (__uint128_t{bytes[7]} << 64) | (__uint128_t{bytes[8]} << 56) | + (__uint128_t{bytes[9]} << 48) | (__uint128_t{bytes[10]} << 40) | (__uint128_t{bytes[11]} << 32) | + (__uint128_t{bytes[12]} << 24) | (__uint128_t{bytes[13]} << 16) | (__uint128_t{bytes[14]} << 8) | + (__uint128_t{bytes[15]} << 0); + } + inline int64_t read_s64() { uint64_t dw = read_u64(); union { @@ -198,22 +176,40 @@ struct loadltv { return converter.i; } - inline float read_f32() { - union { - float f; - uint32_t i; - } converter; - converter.i = read_u32(); - return converter.f; + inline single_float_t read_binary16() { + using convert = float_convert; + __uint128_t b = read_u80(); +#ifdef CLASP_SHORT_FLOAT_BINARY16 + return convert::bits_to_float(b); +#else + return convert::quadruple_to_float(convert::bits_to_quadruple>(b)); +#endif } - inline double read_f64() { - union { - double d; - uint64_t i; - } converter; - converter.i = read_u64(); - return converter.d; + inline single_float_t read_binary32() { return float_convert::bits_to_float(read_u32()); } + + inline double_float_t read_binary64() { return float_convert::bits_to_float(read_u64()); } + + inline long_float_t read_binary80() { + using convert = float_convert; + __uint128_t b = read_u80(); +#ifdef CLASP_LONG_FLOAT_BINARY80 + auto q = convert::bits_to_quadruple(b); + return convert::bits_to_float(b); +#else + auto q = convert::bits_to_quadruple>(b); + return convert::quadruple_to_float(convert::bits_to_quadruple>(b)); +#endif + } + + inline long_float_t read_binary128() { + using convert = float_convert; + __uint128_t b = read_u128(); +#ifdef CLASP_LONG_FLOAT_BINARY128 + return convert::bits_to_float(b); +#else + return convert::quadruple_to_float(convert::bits_to_quadruple>(b)); +#endif } // Read a UTF-8 continuation byte or signal an error if invalid. @@ -221,7 +217,8 @@ struct loadltv { uint8_t byte = read_u8(); if (byte >> 6 == 0b10) return byte & 0b111111; - else SIMPLE_ERROR("Invalid UTF-8 in FASL: invalid continuation byte {:02x}", byte); + else + SIMPLE_ERROR("Invalid UTF-8 in FASL: invalid continuation byte {:02x}", byte); } // Read a UTF-8 encoded character. @@ -230,18 +227,14 @@ struct loadltv { if (head >> 7 == 0) return head; else if (head >> 5 == 0b110) - return (claspCharacter)(head & 0b11111) << 6 - | read_continuation_byte(); + return (claspCharacter)(head & 0b11111) << 6 | read_continuation_byte(); else if (head >> 4 == 0b1110) - return (claspCharacter)(head & 0b1111) << 12 - | (claspCharacter)read_continuation_byte() << 6 - | read_continuation_byte(); + return (claspCharacter)(head & 0b1111) << 12 | (claspCharacter)read_continuation_byte() << 6 | read_continuation_byte(); else if (head >> 3 == 0b11110) - return (claspCharacter)(head & 0b111) << 18 - | (claspCharacter)read_continuation_byte() << 12 - | (claspCharacter)read_continuation_byte() << 6 - | read_continuation_byte(); - else SIMPLE_ERROR("Invalid UTF-8 in FASL: invalid header byte {:02x}", head); + return (claspCharacter)(head & 0b111) << 18 | (claspCharacter)read_continuation_byte() << 12 | + (claspCharacter)read_continuation_byte() << 6 | read_continuation_byte(); + else + SIMPLE_ERROR("Invalid UTF-8 in FASL: invalid header byte {:02x}", head); } inline uint8_t read_opcode() { return read_u8(); } @@ -261,9 +254,7 @@ struct loadltv { } } - inline size_t next_index() { - return _next_index++; - } + inline size_t next_index() { return _next_index++; } void check_initialization() { // bool vectors are apparently stupid and weird so using std algorithms @@ -305,73 +296,81 @@ struct loadltv { c->rplacd(get_ltv(read_index())); } - enum class UAETCode : uint8_t { - nil = 0b00000000, - base_char = 0b10000000, - character = 0b11000000, - short_float = 0b10100000, - single_float = 0b00100000, - double_float = 0b01100000, - long_float = 0b11100000, - complex_short = 0b10110000, - complex_single = 0b00110000, - complex_double = 0b01110000, - complex_long = 0b11110000, - bit = 0b00000001, - ub2 = 0b00000010, - ub4 = 0b00000011, - ub8 = 0b00000100, - ub16 = 0b00000101, - ub32 = 0b00000110, - ub64 = 0b00000111, - sb8 = 0b10000100, - sb16 = 0b10000101, - sb32 = 0b10000110, - sb64 = 0b10000111, - t = 0b11111111 - }; - T_sp decode_uaet(uint8_t code) { - switch (UAETCode{code}) { - case UAETCode::nil: + switch (bytecode_uaet{code}) { + case bytecode_uaet::nil: return nil(); - case UAETCode::base_char: + case bytecode_uaet::base_char: return cl::_sym_base_char; - case UAETCode::character: + case bytecode_uaet::character: return cl::_sym_character; - // case UAETCode::short_float: return cl::_sym_ShortFloat_O; - case UAETCode::single_float: + case bytecode_uaet::binary16: +#ifdef CLASP_SHORT_FLOAT + return cl::_sym_short_float; +#else + return cl::_sym_single_float; +#endif + case bytecode_uaet::binary32: return cl::_sym_single_float; - case UAETCode::double_float: - return cl::_sym_DoubleFloat_O; - // case UAETCode::long_float: return cl::_sym_LongFloat_O; - // case UAETCode::complex_short: - // case UAETCode::complex_single: - // case UAETCode::complex_double: - // case UAETCode::complex_long: - case UAETCode::bit: + case bytecode_uaet::binary64: + return cl::_sym_double_float; + case bytecode_uaet::binary80: +#ifdef CLASP_LONG_FLOAT + return cl::_sym_long_float; +#else + return cl::_sym_double_float; +#endif + case bytecode_uaet::binary128: +#ifdef CLASP_LONG_FLOAT + return cl::_sym_long_float; +#else + return cl::_sym_double_float; +#endif + case bytecode_uaet::complex_binary16: +#ifdef CLASP_SHORT_FLOAT + return Cons_O::createList(cl::_sym_complex, cl::_sym_short_float); +#else + return Cons_O::createList(cl::_sym_complex, cl::_sym_single_float); +#endif + case bytecode_uaet::complex_binary32: + return Cons_O::createList(cl::_sym_complex, cl::_sym_single_float); + case bytecode_uaet::complex_binary64: + return Cons_O::createList(cl::_sym_complex, cl::_sym_double_float); + case bytecode_uaet::complex_binary80: +#ifdef CLASP_LONG_FLOAT + return Cons_O::createList(cl::_sym_complex, cl::_sym_long_float); +#else + return Cons_O::createList(cl::_sym_complex, cl::_sym_double_float); +#endif + case bytecode_uaet::complex_binary128: +#ifdef CLASP_LONG_FLOAT + return Cons_O::createList(cl::_sym_complex, cl::_sym_long_float); +#else + return Cons_O::createList(cl::_sym_complex, cl::_sym_double_float); +#endif + case bytecode_uaet::unsigned_byte1: return cl::_sym_bit; - case UAETCode::ub2: + case bytecode_uaet::unsigned_byte2: return ext::_sym_byte2; - case UAETCode::ub4: + case bytecode_uaet::unsigned_byte4: return ext::_sym_byte4; - case UAETCode::ub8: + case bytecode_uaet::unsigned_byte8: return ext::_sym_byte8; - case UAETCode::ub16: + case bytecode_uaet::unsigned_byte16: return ext::_sym_byte16; - case UAETCode::ub32: + case bytecode_uaet::unsigned_byte32: return ext::_sym_byte32; - case UAETCode::ub64: + case bytecode_uaet::unsigned_byte64: return ext::_sym_byte64; - case UAETCode::sb8: + case bytecode_uaet::signed_byte8: return ext::_sym_integer8; - case UAETCode::sb16: + case bytecode_uaet::signed_byte16: return ext::_sym_integer16; - case UAETCode::sb32: + case bytecode_uaet::signed_byte32: return ext::_sym_integer32; - case UAETCode::sb64: + case bytecode_uaet::signed_byte64: return ext::_sym_integer64; - case UAETCode::t: + case bytecode_uaet::t: return cl::_sym_T_O; default: SIMPLE_ERROR("Invalid FASL: Unknown UAET code {:02x}", code); @@ -420,55 +419,76 @@ struct loadltv { for (size_t i = 0; i < total_size; ++i) \ array->rowMajorAset(i, (EXTEXPR)); \ } - switch (UAETCode{packing}) { - case UAETCode::nil: + switch (bytecode_uaet{packing}) { + case bytecode_uaet::nil: break; - case UAETCode::base_char: + case bytecode_uaet::base_char: READ_ARRAY(SimpleBaseString_sp, read_u8(), clasp_make_character(read_u8())); break; - case UAETCode::character: + case bytecode_uaet::character: READ_ARRAY(SimpleCharacterString_sp, read_utf8(), clasp_make_character(read_utf8())); break; - case UAETCode::single_float: - READ_ARRAY(SimpleVector_float_sp, read_f32(), clasp_make_single_float(read_f32())); + case bytecode_uaet::binary16: +#ifdef CLASP_SHORT_FLOAT + READ_ARRAY(SimpleVector_short_float_sp, read_binary16(), ShortFloat_O::create(read_binary16())); +#else + READ_ARRAY(SimpleVector_float_sp, read_binary16(), SingleFloat_dummy_O::create(read_binary16())); +#endif + break; + case bytecode_uaet::binary32: + READ_ARRAY(SimpleVector_float_sp, read_binary32(), clasp_make_single_float(read_binary32())); + break; + case bytecode_uaet::binary64: + READ_ARRAY(SimpleVector_double_sp, read_binary64(), clasp_make_double_float(read_binary64())); + break; + case bytecode_uaet::binary80: +#ifdef CLASP_LONG_FLOAT + READ_ARRAY(SimpleVector_long_float_sp, read_binary80(), LongFloat_O::create(read_binary80())); +#else + READ_ARRAY(SimpleVector_double_sp, read_binary80(), DoubleFloat_O::create(read_binary80())); +#endif break; - case UAETCode::double_float: - READ_ARRAY(SimpleVector_double_sp, read_f64(), clasp_make_double_float(read_f64())); + case bytecode_uaet::binary128: +#ifdef CLASP_LONG_FLOAT + READ_ARRAY(SimpleVector_long_float_sp, read_binary128(), LongFloat_O::create(read_binary128())); +#else + READ_ARRAY(SimpleVector_double_sp, read_binary128(), DoubleFloat_O::create(read_binary128())); +#endif break; - case UAETCode::bit: + case bytecode_uaet::unsigned_byte1: fill_sub_byte(array, total_size, 1); break; - case UAETCode::ub2: + case bytecode_uaet::unsigned_byte2: fill_sub_byte(array, total_size, 2); break; - case UAETCode::ub4: + case bytecode_uaet::unsigned_byte4: fill_sub_byte(array, total_size, 4); break; - case UAETCode::ub8: + case bytecode_uaet::unsigned_byte8: READ_ARRAY(SimpleVector_byte8_t_sp, read_u8(), clasp_make_fixnum(read_u8())); break; - case UAETCode::ub16: + case bytecode_uaet::unsigned_byte16: READ_ARRAY(SimpleVector_byte16_t_sp, read_u16(), clasp_make_fixnum(read_u16())); break; - case UAETCode::ub32: + case bytecode_uaet::unsigned_byte32: READ_ARRAY(SimpleVector_byte32_t_sp, read_u32(), clasp_make_fixnum(read_u32())); break; - case UAETCode::ub64: + case bytecode_uaet::unsigned_byte64: READ_ARRAY(SimpleVector_byte64_t_sp, read_u64(), Integer_O::create(read_u64())); break; - case UAETCode::sb8: + case bytecode_uaet::signed_byte8: READ_ARRAY(SimpleVector_int8_t_sp, read_s8(), clasp_make_fixnum(read_s8())); break; - case UAETCode::sb16: + case bytecode_uaet::signed_byte16: READ_ARRAY(SimpleVector_int16_t_sp, read_s16(), clasp_make_fixnum(read_s16())); break; - case UAETCode::sb32: + case bytecode_uaet::signed_byte32: READ_ARRAY(SimpleVector_int32_t_sp, read_s32(), clasp_make_fixnum(read_s32())); break; - case UAETCode::sb64: + case bytecode_uaet::signed_byte64: READ_ARRAY(SimpleVector_int64_t_sp, read_s64(), Integer_O::create(read_s64())); break; - case UAETCode::t: + case bytecode_uaet::t: break; // handled by setf row-major-aref default: SIMPLE_ERROR("Not implemented: packing code {:02x}", packing); @@ -564,21 +584,36 @@ struct loadltv { set_ltv(bignum_result(ssize, limbs), index); } - void op_float() { + void op_binary16() { + size_t index = next_index(); + set_ltv(ShortFloat_O::create(read_binary16()), index); + } + + void op_binary32() { + size_t index = next_index(); + set_ltv(clasp_make_single_float(read_binary32()), index); + } + + void op_binary64() { size_t index = next_index(); - set_ltv(clasp_make_single_float(read_f32()), index); + set_ltv(clasp_make_double_float(read_binary64()), index); } - void op_double() { + void op_binary80() { size_t index = next_index(); - set_ltv(clasp_make_double_float(read_f64()), index); + set_ltv(LongFloat_O::create(read_binary80()), index); + } + + void op_binary128() { + size_t index = next_index(); + set_ltv(LongFloat_O::create(read_binary128()), index); } void op_ratio() { size_t index = next_index(); Integer_sp num = gc::As(get_ltv(read_index())); Integer_sp den = gc::As(get_ltv(read_index())); - set_ltv(contagion_div(num, den), index); + set_ltv(Ratio_O::create(num, den), index); } void op_complex() { @@ -862,32 +897,32 @@ struct loadltv { for (uint32_t icount = read_u32(); icount > 0; --icount) { uint8_t op = read_u8(); - switch (op) { - case LTV_DI_OP_FUNCTION: + switch (bytecode_debug_info{op}) { + case bytecode_debug_info::function: vargs.push_back(di_op_function()); break; - case LTV_DI_OP_VARS: + case bytecode_debug_info::vars: vargs.push_back(di_op_vars()); break; - case LTV_DI_OP_LOCATION: + case bytecode_debug_info::location: vargs.push_back(di_op_location()); break; - case LTV_DI_OP_DECLS: + case bytecode_debug_info::decls: vargs.push_back(di_op_decls()); break; - case LTV_DI_OP_THE: + case bytecode_debug_info::the: vargs.push_back(di_op_the()); break; - case LTV_DI_OP_BLOCK: + case bytecode_debug_info::block: vargs.push_back(di_op_block()); break; - case LTV_DI_OP_MACRO: + case bytecode_debug_info::macro: vargs.push_back(di_op_macro()); break; - case LTV_DI_OP_IF: + case bytecode_debug_info::_if: vargs.push_back(di_op_if()); break; - case LTV_DI_OP_TAGBODY: + case bytecode_debug_info::tagbody: vargs.push_back(di_op_tagbody()); break; default: @@ -985,104 +1020,113 @@ struct loadltv { void load_instruction() { uint8_t opcode = read_opcode(); // fmt::print("op {:02x}\n", opcode); - switch (opcode) { - case LTV_OP_NIL: + switch (bytecode_ltv{opcode}) { + case bytecode_ltv::nil: op_nil(); break; - case LTV_OP_T: + case bytecode_ltv::t: op_t(); break; - case LTV_OP_CONS: + case bytecode_ltv::ratio: + op_ratio(); + break; + case bytecode_ltv::complex: + op_complex(); + break; + case bytecode_ltv::cons: op_cons(); break; - case LTV_OP_RPLACA: + case bytecode_ltv::rplaca: op_rplaca(); break; - case LTV_OP_RPLACD: + case bytecode_ltv::rplacd: op_rplacd(); break; - case LTV_OP_MAKE_ARRAY: + case bytecode_ltv::make_array: op_array(); break; - case LTV_OP_SRMA: + case bytecode_ltv::setf_row_major_aref: op_srma(); break; // (setf row-major-aref) - case LTV_OP_HASHT: + case bytecode_ltv::make_hash_table: op_hasht(); break; // make-hash-table - case LTV_OP_SHASH: + case bytecode_ltv::setf_gethash: op_shash(); break; // (setf gethash) - case LTV_OP_SB64: + case bytecode_ltv::make_sb64: op_sb64(); break; - case LTV_OP_PACKAGE: + case bytecode_ltv::find_package: op_package(); break; - case LTV_OP_BIGNUM: + case bytecode_ltv::make_bignum: op_bignum(); break; - case LTV_OP_FLOAT: - op_float(); - break; - case LTV_OP_DOUBLE: - op_double(); - break; - case LTV_OP_RATIO: - op_ratio(); - break; - case LTV_OP_COMPLEX: - op_complex(); - break; - case LTV_OP_SYMBOL: + case bytecode_ltv::make_symbol: op_symbol(); break; - case LTV_OP_INTERN: + case bytecode_ltv::intern: op_intern(); break; - case LTV_OP_CHARACTER: + case bytecode_ltv::make_character: op_character(); break; - case LTV_OP_PATHNAME: + case bytecode_ltv::make_pathname: op_pathname(); break; - case LTV_OP_BCFUNC: + case bytecode_ltv::make_bytecode_function: op_bcfunc(); break; - case LTV_OP_BCMOD: + case bytecode_ltv::make_bytecode_module: op_bcmod(); break; - case LTV_OP_SLITS: + case bytecode_ltv::setf_literals: op_slits(); break; // setf literals - case LTV_OP_FDEF: - op_fdef(); + case bytecode_ltv::make_binary16: + op_binary16(); break; - case LTV_OP_FCELL: - op_fcell(); + case bytecode_ltv::make_binary32: + op_binary32(); break; - case LTV_OP_VCELL: - op_vcell(); + case bytecode_ltv::make_binary64: + op_binary64(); + break; + case bytecode_ltv::make_binary80: + op_binary80(); + break; + case bytecode_ltv::make_binary128: + op_binary128(); break; - case LTV_OP_CREATE: + case bytecode_ltv::funcall_create: op_create(); break; // funcall-create - case LTV_OP_INIT: + case bytecode_ltv::funcall_initialize: op_init(); break; // funcall-initialize - case LTV_OP_CLASS: + case bytecode_ltv::fdefinition: + op_fdef(); + break; + case bytecode_ltv::fcell: + op_fcell(); + break; + case bytecode_ltv::vcell: + op_vcell(); + break; + case bytecode_ltv::find_class: op_class(); break; - case LTV_OP_INIT_OBJECT_ARRAY: + case bytecode_ltv::init_object_array: op_init_object_array(); break; - case LTV_OP_ENVIRONMENT: + case bytecode_ltv::environment: op_environment(); break; - case LTV_OP_SYMBOL_VALUE: + case bytecode_ltv::symbol_value: op_symbol_value(); break; - case LTV_OP_ATTR: + case bytecode_ltv::attribute: op_attribute(); break; default: @@ -1119,7 +1163,7 @@ CL_DEFUN bool load_bytecode(T_sp filename, bool verbose, bool print, T_sp extern struct ltv_MmapInfo { uint8_t* _Memory; size_t _Len; - ltv_MmapInfo(uint8_t* mem, size_t len) : _Memory(mem), _Len(len){}; + ltv_MmapInfo(uint8_t* mem, size_t len) : _Memory(mem), _Len(len) {}; }; CL_LAMBDA(output-designator files &optional (verbose nil)); diff --git a/src/core/num_arith.cc b/src/core/num_arith.cc index a53ac24499..5cc86cf36e 100644 --- a/src/core/num_arith.cc +++ b/src/core/num_arith.cc @@ -48,38 +48,25 @@ THE SOFTWARE. #include #include #include -#include namespace core { // This is a truncating division. Integer_sp clasp_integer_divide(Integer_sp x, Integer_sp y) { - MATH_DISPATCH_BEGIN(x, y) { - case_Fixnum_v_Fixnum : { - Fixnum fy = y.unsafe_fixnum(); - if (fy == 0) - ERROR_DIVISION_BY_ZERO(x, y); - else - // Note that / truncates towards zero as of C++11, as we want. - return clasp_make_fixnum(x.unsafe_fixnum() / fy); - } - case_Fixnum_v_Bignum: - return fix_divided_by_next(x.unsafe_fixnum(), gc::As_unsafe(x)); - case_Bignum_v_Fixnum : { - T_mv trunc = core__next_ftruncate(gc::As_unsafe(x), y.unsafe_fixnum()); - return gc::As_unsafe(trunc); - } - case_Bignum_v_Bignum : { - // FIXME: MPN doesn't export a quotient-only division that I can see, - // but we could call a version of truncate that doesn't cons up the - // actual bignum for the remainder, hypothetically. - // Would save some heap allocation. - T_mv trunc = core__next_truncate(gc::As_unsafe(x), gc::As_unsafe(y)); - return gc::As_unsafe(trunc); - } - }; - MATH_DISPATCH_END(); - UNREACHABLE(); + Bignum_sp bx = x.asOrNull(), by = y.asOrNull(); + if (bx && by) + return core__next_truncate(bx, by).as_unsafe(); + if (bx) + return core__next_ftruncate(bx, y.unsafe_fixnum()).as_unsafe(); + if (by) + return fix_divided_by_next(x.unsafe_fixnum(), by); + + Fixnum fy = y.unsafe_fixnum(); + if (fy == 0) + ERROR_DIVISION_BY_ZERO(x, y); + else + // Note that / truncates towards zero as of C++11, as we want. + return clasp_make_fixnum(x.unsafe_fixnum() / fy); } CL_LAMBDA(&rest nums); @@ -94,7 +81,7 @@ CL_DEFUN Integer_sp cl__gcd(List_sp nums) { Integer_sp gcd = gc::As(oCar(nums)); nums = oCdr(nums); if (nums.nilp()) { - return (clasp_minusp(gcd) ? gc::As(clasp_negate(gcd)) : gcd); + return (Real_O::minusp(gcd) ? gc::As(clasp_negate(gcd)) : gcd); } while (nums.consp()) { gcd = clasp_gcd(gcd, gc::As(oCar(nums))); @@ -114,19 +101,15 @@ gc::Fixnum gcd(gc::Fixnum a, gc::Fixnum b) { } Integer_sp clasp_gcd(Integer_sp x, Integer_sp y, int yidx) { - MATH_DISPATCH_BEGIN(x, y) { - case_Fixnum_v_Fixnum: - return clasp_make_fixnum(gcd(x.unsafe_fixnum(), y.unsafe_fixnum())); - case_Fixnum_v_Bignum: - return core__next_fgcd(gc::As_unsafe(y), x.unsafe_fixnum()); - case_Bignum_v_Fixnum: - return core__next_fgcd(gc::As_unsafe(x), y.unsafe_fixnum()); - case_Bignum_v_Bignum: - return core__next_gcd(gc::As_unsafe(x), gc::As_unsafe(y)); - default: - UNREACHABLE(); - }; - MATH_DISPATCH_END(); + Bignum_sp bx = x.asOrNull(), by = y.asOrNull(); + if (bx && by) + return core__next_gcd(bx, by); + if (bx) + return core__next_fgcd(bx, y.unsafe_fixnum()); + if (by) + return core__next_fgcd(by, x.unsafe_fixnum()); + + return clasp_make_fixnum(gcd(x.unsafe_fixnum(), y.unsafe_fixnum())); } CL_LAMBDA(&rest args); @@ -146,13 +129,13 @@ CL_DEFUN Integer_sp cl__lcm(List_sp nums) { Integer_sp numi = gc::As(oCar(nums)); nums = oCdr(nums); yidx++; - Number_sp t = clasp_times(lcm, numi); + Number_sp t = lcm * numi; Number_sp g = clasp_gcd(numi, lcm); - if (!clasp_zerop(g)) { - lcm = gc::As(clasp_divide(t, g)); + if (!Number_O::zerop(g)) { + lcm = gc::As(t / g); } } - return clasp_minusp(lcm) ? gc::As(clasp_negate(lcm)) : gc::As(lcm); + return Real_O::minusp(lcm) ? gc::As(clasp_negate(lcm)) : gc::As(lcm); }; SYMBOL_EXPORT_SC_(ClPkg, gcd); diff --git a/src/core/num_co.cc b/src/core/num_co.cc index 68ba57afbf..1b7e770e3e 100644 --- a/src/core/num_co.cc +++ b/src/core/num_co.cc @@ -59,7 +59,6 @@ THE SOFTWARE. #include #include #include -#include #ifndef HAVE_ISOC99 #define floorf floor @@ -82,65 +81,57 @@ namespace core { /* Coerce X to single-float if one arg, otherwise coerce to same float type as second arg */ -CL_LAMBDA(x &optional y); +CL_LAMBDA(x &optional (y nil yp)); CL_DECLARE(); CL_UNWIND_COOP(true); CL_DOCSTRING(R"dx(float)dx"); DOCGROUP(clasp); -CL_DEFUN Float_sp cl__float(Real_sp x, T_sp y) { - NumberType ty, tx; - if (y.notnilp()) { - ty = clasp_t_of(gc::As(y)); - } else { - ty = number_SingleFloat; +CL_DEFUN Float_sp cl__float(Real_sp x, T_sp y, bool yp) { + if (!yp) { + if (x.isA()) + return x.as_unsafe(); + return SingleFloat_dummy_O::coerce(x); } - switch (tx = clasp_t_of(x)) { - case number_SingleFloat: - case number_DoubleFloat: + #ifdef CLASP_LONG_FLOAT - case number_LongFloat: + if (y.isA()) + return LongFloat_O::coerce(x); #endif - if (y.nilp() || ty == tx) - return gc::As_unsafe(x); - // otherwise, fall through - case number_Fixnum: - case number_Bignum: - case number_Ratio: - switch (ty) { - case number_SingleFloat: - return clasp_make_single_float(clasp_to_float(x)); - case number_DoubleFloat: - return clasp_make_double_float(clasp_to_double(x)); -#ifdef CLASP_LONG_FLOAT - case number_LongFloat: - return clasp_make_long_float(clasp_to_long_float(x)).as(); + + if (y.isA()) + return DoubleFloat_O::coerce(x); + + if (y.single_floatp()) + return SingleFloat_dummy_O::coerce(x); + +#ifdef CLASP_SHORT_FLOAT + if (y.short_floatp()) + return ShortFloat_O::coerce(x); #endif - default: - ERROR_WRONG_TYPE_NTH_ARG(cl::_sym_float, 2, y, cl::_sym_float); - } - default: - ERROR_WRONG_TYPE_NTH_ARG(cl::_sym_float, 1, x, cl::_sym_Real_O); - } + + ERROR_WRONG_TYPE_NTH_ARG(cl::_sym_float, 2, y, cl::_sym_float); } // Simpler versions used by the compiler. +#ifdef CLASP_SHORT_FLOAT CL_UNWIND_COOP(true); DOCGROUP(clasp); -CL_DEFUN SingleFloat_sp core__to_single_float(Real_sp x) { - if (x.single_floatp()) - return gc::As_unsafe(x); - else - return clasp_make_single_float(clasp_to_double(x)); -} +CL_DEFUN ShortFloat_sp core__to_short_float(Real_sp x) { return ShortFloat_O::coerce(x); } +#endif CL_UNWIND_COOP(true); DOCGROUP(clasp); -CL_DEFUN DoubleFloat_sp core__to_double_float(Real_sp x) { - if (gc::IsA(x)) - return gc::As_unsafe(x); - else - return clasp_make_double_float(clasp_to_double(x)); -} +CL_DEFUN SingleFloat_sp core__to_single_float(Real_sp x) { return SingleFloat_dummy_O::coerce(x); } + +CL_UNWIND_COOP(true); +DOCGROUP(clasp); +CL_DEFUN DoubleFloat_sp core__to_double_float(Real_sp x) { return DoubleFloat_O::coerce(x); } + +#ifdef CLASP_LONG_FLOAT +CL_UNWIND_COOP(true); +DOCGROUP(clasp); +CL_DEFUN LongFloat_sp core__to_long_float(Real_sp x) { return LongFloat_O::coerce(x); } +#endif CL_LAMBDA(x); CL_DECLARE(); @@ -148,15 +139,13 @@ CL_UNWIND_COOP(true); CL_DOCSTRING(R"dx(numerator)dx"); DOCGROUP(clasp); CL_DEFUN Integer_sp cl__numerator(Rational_sp x) { - switch (clasp_t_of(x)) { - case number_Ratio: - return gc::As_unsafe(x)->numerator(); - case number_Fixnum: - case number_Bignum: - return gc::As_unsafe(x); - default: - ERROR_WRONG_TYPE_NTH_ARG(cl::_sym_numerator, 1, x, cl::_sym_Rational_O); - } + Ratio_sp rx = x.asOrNull(); + if (rx) + return rx->numerator(); + if (x.fixnump()) + return x.as_unsafe(); + + return x.as(); } CL_LAMBDA(x); @@ -165,15 +154,18 @@ CL_UNWIND_COOP(true); CL_DOCSTRING(R"dx(denominator)dx"); DOCGROUP(clasp); CL_DEFUN Number_sp cl__denominator(Rational_sp x) { - switch (clasp_t_of(x)) { - case number_Ratio: - return gc::As_unsafe(x)->denominator(); - case number_Fixnum: - case number_Bignum: - return clasp_make_fixnum(1); - default: - ERROR_WRONG_TYPE_NTH_ARG(cl::_sym_denominator, 1, x, cl::_sym_Rational_O); - } + Ratio_sp rx = x.asOrNull(); + if (rx) + return rx->denominator(); + + return clasp_make_fixnum(1); +} + +template void float_trunc(Float dividend, Float divisor, Integer_sp& quotient, Real_sp& remainder) { + Float p = dividend / divisor; + Float q = std::trunc(p); + quotient = Integer_O::create(q); + remainder = Number_O::make_float(p * divisor - q * divisor); } // Stores the result in quotient, remainder. @@ -181,243 +173,142 @@ static void clasp_truncate(Real_sp dividend, Real_sp divisor, Integer_sp& quotie // The CL standard is a bit ambiguous about the type of the remainder. // We treat it as a contagion thing: If either argument is a float, the // remainder is a float of the largest format among the arguments. - MATH_DISPATCH_BEGIN(dividend, divisor) { - case_Fixnum_v_Fixnum : { - Fixnum a = dividend.unsafe_fixnum(); - Fixnum b = divisor.unsafe_fixnum(); - // Uniquely, (truncate most-negative-fixnum -1) is a bignum, so - // we can't just use clasp_make_fixnum for the quotient. - quotient = Integer_O::create(a / b); - remainder = clasp_make_fixnum(a % b); - return; - } - case_Fixnum_v_Bignum : { - // This is always a zero quotient, except when - // we have MOST_NEGATIVE_FIXNUM / - MOST_NEGATIVE_FIXNUM. - Fixnum a = dividend.unsafe_fixnum(); - Bignum_sp b = gc::As_unsafe(divisor); - if ((a == gc::most_negative_fixnum) && (b->length() == 1) && ((b->limbs())[0] == -gc::most_negative_fixnum)) { - quotient = clasp_make_fixnum(-1); - remainder = clasp_make_fixnum(0); - } else { - quotient = clasp_make_fixnum(0); - remainder = dividend; - } - return; - } - case_Fixnum_v_Ratio: - case_Bignum_v_Ratio : { - Ratio_sp ry = gc::As(divisor); + Ratio_sp rdividend = dividend.asOrNull(), rdivisor = divisor.asOrNull(); + if (rdividend && rdivisor) { Real_sp subr; - Number_sp product = clasp_times(dividend, ry->denominator()); - clasp_truncate(gc::As_unsafe(product), ry->numerator(), quotient, subr); - remainder = Rational_O::create(gc::As_unsafe(subr), ry->denominator()); + clasp_truncate(rdividend->numerator() * rdivisor->denominator(), rdivisor->numerator() * rdividend->denominator(), quotient, + subr); + remainder = Rational_O::create(gc::As(subr), rdividend->denominator() * rdivisor->denominator()); return; } - case_Fixnum_v_SingleFloat : { - float n = divisor.unsafe_single_float(); - float p = dividend.unsafe_fixnum() / n; - float q = std::trunc(p); - quotient = _clasp_float_to_integer(q); - remainder = clasp_make_single_float(p * n - q * n); + if (rdividend) { + Real_sp subr; + clasp_truncate(rdividend->numerator(), rdividend->denominator().as_unsafe() * divisor, quotient, subr); + remainder = subr / rdividend->denominator().as_unsafe(); return; } - case_Fixnum_v_DoubleFloat : { - double n = gc::As_unsafe(divisor)->get(); - double p = dividend.unsafe_fixnum() / n; - double q = std::trunc(p); - quotient = _clasp_double_to_integer(q); - remainder = clasp_make_double_float(p * n - q * n); + if (rdivisor && dividend.isA()) { + Real_sp subr; + clasp_truncate(dividend * rdivisor->denominator().as_unsafe(), rdivisor->numerator(), quotient, subr); + remainder = Rational_O::create(gc::As(subr), rdivisor->denominator()); return; } + #ifdef CLASP_LONG_FLOAT - case_Fixnum_v_LongFloat : { - LongFloat n = clasp_long_float(divisor); - LongFloat p = dividend.unsafe_fixnum() / n; - LongFloat q = std::trunc(p); - quotient = _clasp_long_double_to_integer(q); - remainder = clasp_make_long_float(p * n - q * n); + if (dividend.isA() || divisor.isA()) { + float_trunc(Number_O::as_long_float(dividend), Number_O::as_long_float(divisor), quotient, remainder); return; } #endif - case_Bignum_v_Fixnum : { - Bignum_sp bdividend = gc::As_unsafe(dividend); - Fixnum fdivisor = divisor.unsafe_fixnum(); - T_mv rmv = core__next_ftruncate(bdividend, fdivisor); - quotient = gc::As_unsafe(rmv); - MultipleValues& mvn = core::lisp_multipleValues(); - remainder = gc::As_unsafe(mvn.valueGet(1, rmv.number_of_values())); - return; - } - case_Bignum_v_Bignum : { - Bignum_sp bdividend = gc::As_unsafe(dividend); - Bignum_sp bdivisor = gc::As_unsafe(divisor); - T_mv mvr = core__next_truncate(bdividend, bdivisor); - quotient = gc::As_unsafe(mvr); - MultipleValues& mvn = core::lisp_multipleValues(); - remainder = gc::As_unsafe(mvn.valueGet(1, mvr.number_of_values())); - return; - } - // case_Bignum_v_Ratio: above - case_Bignum_v_SingleFloat : { - float n = divisor.unsafe_single_float(); - float p = gc::As_unsafe(dividend)->as_float_() / n; - float q = std::trunc(p); - quotient = _clasp_float_to_integer(q); - remainder = clasp_make_single_float(p * n - q * n); - return; - } - case_Bignum_v_DoubleFloat : { - double n = gc::As_unsafe(divisor)->get(); - double p = gc::As_unsafe(dividend)->as_double_() / n; - double q = std::trunc(p); - quotient = _clasp_double_to_integer(q); - remainder = clasp_make_double_float(p * n - q * n); + + if (dividend.isA() || divisor.isA()) { + float_trunc(Number_O::as_double_float(dividend), Number_O::as_double_float(divisor), quotient, remainder); return; } -#ifdef CLASP_LONG_FLOAT - case_Bignum_v_LongFloat : { - LongFloat n = clasp_long_float(divisor); - LongFloat p = gc::As_unsafe(dividend)->as_long_float_() / n; - LongFloat q = std::trunc(p); - quotient = _clasp_long_double_to_integer(q); - remainder = clasp_make_long_float(p * n - q * n); + + if (dividend.single_floatp() || divisor.single_floatp()) { + float_trunc(Number_O::as_single_float(dividend), Number_O::as_single_float(divisor), quotient, remainder); return; } -#endif - case_Ratio_v_Ratio : { - Ratio_sp rx = gc::As_unsafe(dividend); - Ratio_sp ry = gc::As_unsafe(divisor); - Real_sp subr; - Real_sp c1 = gc::As_unsafe(clasp_times(rx->numerator(), ry->denominator())); - Real_sp c2 = gc::As_unsafe(clasp_times(ry->numerator(), rx->denominator())); - Real_sp nd = gc::As_unsafe(clasp_times(rx->denominator(), ry->denominator())); - clasp_truncate(c1, c2, quotient, subr); - remainder = Rational_O::create(gc::As_unsafe(subr), gc::As_unsafe(nd)); + +#ifdef CLASP_SHORT_FLOAT + if (dividend.short_floatp() || divisor.short_floatp()) { + float_trunc(Number_O::as_short_float(dividend), Number_O::as_short_float(divisor), quotient, remainder); return; } - case_Ratio_v_Fixnum: - case_Ratio_v_Bignum: -#ifdef CLASP_LONG_FLOAT - case_Ratio_v_LongFloat: #endif - case_Ratio_v_SingleFloat: - case_Ratio_v_DoubleFloat : { - // Given (truncate x (* y z)) = q, r, - // (truncate x/y z) = q, r/y. - Ratio_sp rx = gc::As_unsafe(dividend); - Integer_sp den = rx->denominator(); - Real_sp ndiv = gc::As_unsafe(clasp_times(den, divisor)); - Real_sp subr; - clasp_truncate(rx->numerator(), ndiv, quotient, subr); - remainder = gc::As_unsafe(clasp_divide(subr, den)); - return; - } - case_SingleFloat_v_Fixnum: - case_SingleFloat_v_Bignum: - case_SingleFloat_v_SingleFloat: - case_SingleFloat_v_Ratio : { - float n = clasp_to_float(divisor); - float p = dividend.unsafe_single_float() / n; - float q = std::trunc(p); - quotient = _clasp_float_to_integer(q); - remainder = clasp_make_single_float(p * n - q * n); + + Bignum_sp bdividend = dividend.asOrNull(), bdivisor = divisor.asOrNull(); + if (bdividend && bdivisor) { + Number_mv mvr = core__next_truncate(bdividend, bdivisor); + quotient = gc::As_unsafe(mvr); + MultipleValues& mvn = core::lisp_multipleValues(); + remainder = gc::As_unsafe(mvn.valueGet(1, mvr.number_of_values())); return; } - case_DoubleFloat_v_Fixnum: - case_DoubleFloat_v_Bignum: - case_SingleFloat_v_DoubleFloat: - case_DoubleFloat_v_SingleFloat: - case_DoubleFloat_v_DoubleFloat: -#ifdef CLASP_LONG_FLOAT - case_DoubleFloat_v_LongFloat: - case_SingleFloat_v_LongFloat: -#endif - case_DoubleFloat_v_Ratio : { - double n = clasp_to_double(divisor); - double p = clasp_to_double(dividend) / n; - double q = std::trunc(p); - quotient = _clasp_double_to_integer(q); - remainder = clasp_make_double_float(p * n - q * n); + if (bdividend) { + Number_mv rmv = core__next_ftruncate(bdividend, divisor.unsafe_fixnum()); + quotient = gc::As_unsafe(rmv); + MultipleValues& mvn = core::lisp_multipleValues(); + remainder = gc::As_unsafe(mvn.valueGet(1, rmv.number_of_values())); return; } -#ifdef CLASP_LONG_FLOAT - case_LongFloat_v_Fixnum: - case_LongFloat_v_Bignum: - case_LongFloat_v_SingleFloat: - case_LongFloat_v_DoubleFloat: - case_LongFloat_v_LongFloat : { - LongFloat n = clasp_to_long_double(divisor); - LongFloat p = clasp_long_float(dividend) / n; - LongFloat q = std::trunc(p); - quotient = _clasp_long_double_to_integer(q); - remainder = clasp_make_long_float(p * n - q * n); + if (bdivisor) { + Fixnum a = dividend.unsafe_fixnum(); + if ((a == gc::most_negative_fixnum) && (bdivisor->length() == 1) && ((bdivisor->limbs())[0] == -gc::most_negative_fixnum)) { + quotient = clasp_make_fixnum(-1); + remainder = clasp_make_fixnum(0); + } else { + quotient = clasp_make_fixnum(0); + remainder = dividend; + } return; } -#endif - default: - UNREACHABLE(); - }; - MATH_DISPATCH_END(); + + Fixnum a = dividend.unsafe_fixnum(); + Fixnum b = divisor.unsafe_fixnum(); + // Uniquely, (truncate most-negative-fixnum -1) is a bignum, so + // we can't just use clasp_make_fixnum for the quotient. + quotient = Integer_O::create(a / b); + remainder = clasp_make_fixnum(a % b); } static void clasp_floor(Real_sp dividend, Real_sp divisor, Integer_sp& quotient, Real_sp& remainder) { Integer_sp t0; Real_sp t1; clasp_truncate(dividend, divisor, t0, t1); - if (!(clasp_zerop(t1)) && (clasp_minusp(divisor) ? clasp_plusp(dividend) : clasp_minusp(dividend))) { + if (!(Number_O::zerop(t1)) && (Real_O::minusp(divisor) ? Real_O::plusp(dividend) : Real_O::minusp(dividend))) { quotient = gc::As_unsafe(clasp_one_minus(t0)); - remainder = gc::As_unsafe(clasp_plus(t1, divisor)); + remainder = gc::As_unsafe(t1 + divisor); } else { quotient = t0; remainder = t1; } } +template Real_mv _floor1(Float x) { + switch (std::fpclassify(x)) { + case FP_NAN: + feraiseexcept(FE_INVALID); + return Values(clasp_make_fixnum(0), Number_O::make_float(x)); + case FP_INFINITE: + return Values(clasp_make_fixnum(0), Number_O::make_float(x)); + default: { + Float f = std::floor(x); + return Values(Integer_O::create(f), Number_O::make_float(x - f)); + } + } +} + Real_mv clasp_floor1(Real_sp x) { - switch (clasp_t_of(x)) { - case number_Fixnum: - case number_Bignum: + if (x.fixnump() || x.isA()) return Values(x, clasp_make_fixnum(0)); - case number_Ratio: { - Ratio_sp rx(gc::As_unsafe(x)); + + Ratio_sp rx = x.asOrNull(); + if (rx) { Integer_sp v0; Real_sp tv1; clasp_floor(rx->numerator(), rx->denominator(), v0, tv1); - return Values(v0, Ratio_O::create(gc::As_unsafe(tv1), rx->denominator())); - } - case number_SingleFloat: { - float d = x.unsafe_single_float(); - if (std::isnan(d)) - return Values(x, clasp_make_fixnum(0)); - else { - float y = floorf(d); - return Values(_clasp_float_to_integer(y), clasp_make_single_float(d - y)); - } - } - case number_DoubleFloat: { - double d = gc::As(x)->get(); - if (std::isnan(d)) - return Values(x, clasp_make_fixnum(0)); - else { - double y = floor(d); - return Values(_clasp_double_to_integer(y), clasp_make_double_float(d - y)); - } + return Values(v0, Ratio_O::create(tv1.as_unsafe(), rx->denominator())); } + #ifdef CLASP_LONG_FLOAT - case number_LongFloat: { - LongFloat d = clasp_long_float(x); - if (std::isnan(d)) - return Values(x, clasp_make_fixnum(0)); - else { - LongFloat y = floorl(d); - return Values(_clasp_long_double_to_integer(y), v1 = clasp_make_long_float(d - y)); - } - } + if (x.isA()) + return _floor1(x.as_unsafe()->get()); #endif - default: - ERROR_WRONG_TYPE_NTH_ARG(cl::_sym_floor, 1, x, cl::_sym_Real_O); - } + + if (x.isA()) + return _floor1(x.as_unsafe()->get()); + + if (x.single_floatp()) + return _floor1(x.unsafe_single_float()); + +#ifdef CLASP_SHORT_FLOAT + if (x.short_floatp()) + return _floor1(x.unsafe_short_float()); +#endif + + ERROR_WRONG_TYPE_NTH_ARG(cl::_sym_floor, 1, x, cl::_sym_Real_O); } Real_mv clasp_floor2(Real_sp dividend, Real_sp divisor) { @@ -443,47 +334,58 @@ static void clasp_ceiling(Real_sp dividend, Real_sp divisor, Integer_sp& quotien Integer_sp t0; Real_sp t1; clasp_truncate(dividend, divisor, t0, t1); - if (!(clasp_zerop(t1)) && (clasp_minusp(divisor) ? clasp_minusp(dividend) : clasp_plusp(dividend))) { + if (!(Number_O::zerop(t1)) && (Real_O::minusp(divisor) ? Real_O::minusp(dividend) : Real_O::plusp(dividend))) { quotient = gc::As_unsafe(clasp_one_plus(t0)); - remainder = gc::As_unsafe(clasp_minus(t1, divisor)); + remainder = gc::As_unsafe(t1 - divisor); } else { quotient = t0; remainder = t1; } } -Real_mv clasp_ceiling1(Real_sp x) { - switch (clasp_t_of(x)) { - case number_Fixnum: - case number_Bignum: - return Values(x, clasp_make_fixnum(0)); - case number_Ratio: { - Integer_sp t0; - Real_sp t1; - Ratio_sp rx = gc::As_unsafe(x); - clasp_ceiling(rx->numerator(), rx->denominator(), t0, t1); - return Values(t0, Ratio_O::create(gc::As_unsafe(t1), rx->denominator())); +template Real_mv _ceiling1(Float x) { + switch (std::fpclassify(x)) { + case FP_NAN: + feraiseexcept(FE_INVALID); + return Values(clasp_make_fixnum(0), Number_O::make_float(x)); + case FP_INFINITE: + return Values(clasp_make_fixnum(0), Number_O::make_float(x)); + default: { + Float f = std::ceil(x); + return Values(Integer_O::create(f), Number_O::make_float(x - f)); } - case number_SingleFloat: { - float d = x.unsafe_single_float(); - float y = ceilf(d); - return Values(_clasp_float_to_integer(y), clasp_make_single_float(d - y)); } - case number_DoubleFloat: { - double d = gc::As_unsafe(x)->get(); - double y = ceil(d); - return Values(_clasp_double_to_integer(y), clasp_make_double_float(d - y)); +} + +Real_mv clasp_ceiling1(Real_sp x) { + if (x.fixnump() || x.isA()) + return Values(x, clasp_make_fixnum(0)); + + Ratio_sp rx = x.asOrNull(); + if (rx) { + Integer_sp v0; + Real_sp tv1; + clasp_ceiling(rx->numerator(), rx->denominator(), v0, tv1); + return Values(v0, Ratio_O::create(tv1.as_unsafe(), rx->denominator())); } + #ifdef CLASP_LONG_FLOAT - case number_LongFloat: { - LongFloat d = clasp_long_float(x); - LongFloat y = ceill(d); - return Values(_clasp_long_double_to_integer(y), clasp_make_long_float(d - y)); - } + if (x.isA()) + return _ceiling1(x.as_unsafe()->get()); #endif - default: - ERROR_WRONG_TYPE_NTH_ARG(cl::_sym_ceiling, 1, x, cl::_sym_Real_O); - } + + if (x.isA()) + return _ceiling1(x.as_unsafe()->get()); + + if (x.single_floatp()) + return _ceiling1(x.unsafe_single_float()); + +#ifdef CLASP_SHORT_FLOAT + if (x.short_floatp()) + return _ceiling1(x.unsafe_short_float()); +#endif + + ERROR_WRONG_TYPE_NTH_ARG(cl::_sym_floor, 1, x, cl::_sym_Real_O); } Real_mv clasp_ceiling2(Real_sp dividend, Real_sp divisor) { @@ -505,38 +407,49 @@ CL_DEFUN Real_mv cl__ceiling(Real_sp dividend, T_sp divisor) { return clasp_ceiling2(dividend, gc::As(divisor)); } +template Real_mv _truncate1(Float x) { + switch (std::fpclassify(x)) { + case FP_NAN: + feraiseexcept(FE_INVALID); + return Values(clasp_make_fixnum(0), Number_O::make_float(x)); + case FP_INFINITE: + return Values(clasp_make_fixnum(0), Number_O::make_float(x)); + default: { + Float f = std::signbit(x) ? std::ceil(x) : std::floor(x); + return Values(Integer_O::create(f), Number_O::make_float(x - f)); + } + } +} + Real_mv clasp_truncate1(Real_sp x) { - switch (clasp_t_of(x)) { - case number_Fixnum: - case number_Bignum: + if (x.fixnump() || x.isA()) return Values(x, clasp_make_fixnum(0)); - case number_Ratio: { - Ratio_sp rx = gc::As(x); + + Ratio_sp rx = x.asOrNull(); + if (rx) { Integer_sp v0; - Real_sp v1; - clasp_truncate(rx->numerator(), rx->denominator(), v0, v1); - return Values(v0, Ratio_O::create(gc::As_unsafe(v1), rx->denominator())); - } - case number_SingleFloat: { - float d = x.unsafe_single_float(); - float y = d > 0 ? floorf(d) : ceilf(d); - return Values(_clasp_float_to_integer(y), clasp_make_single_float(d - y)); - } - case number_DoubleFloat: { - double d = gc::As_unsafe(x)->get(); - double y = d > 0 ? floor(d) : ceil(d); - return Values(_clasp_double_to_integer(y), clasp_make_double_float(d - y)); + Real_sp tv1; + clasp_truncate(rx->numerator(), rx->denominator(), v0, tv1); + return Values(v0, Ratio_O::create(tv1.as_unsafe(), rx->denominator())); } + #ifdef CLASP_LONG_FLOAT - case number_LongFloat: { - LongFloat d = clasp_long_float(x); - LongFloat y = d > 0 ? floorl(d) : ceill(d); - return Values(_clasp_long_double_to_integer(y), clasp_make_long_float(d - y)); - } + if (x.isA()) + return _truncate1(x.as_unsafe()->get()); #endif - default: - ERROR_WRONG_TYPE_NTH_ARG(cl::_sym_truncate, 1, x, cl::_sym_Real_O); - } + + if (x.isA()) + return _truncate1(x.as_unsafe()->get()); + + if (x.single_floatp()) + return _truncate1(x.unsafe_single_float()); + +#ifdef CLASP_SHORT_FLOAT + if (x.short_floatp()) + return _truncate1(x.unsafe_short_float()); +#endif + + ERROR_WRONG_TYPE_NTH_ARG(cl::_sym_floor, 1, x, cl::_sym_Real_O); } Real_mv clasp_truncate2(Real_sp x, Real_sp y) { @@ -558,71 +471,39 @@ CL_DEFUN Real_mv cl__truncate(Real_sp dividend, T_sp divisor) { return clasp_truncate2(dividend, gc::As(divisor)); } -static double round_double(double d) { - if (d >= 0) { - double q = floor(d += 0.5); - if (q == d) { - int i = (int)fmod(q, 10); - if (i & 1) { - return q - 1; - } - } - return q; - } else { - return -round_double(-d); - } -} - -#ifdef CLASP_LONG_FLOAT -static LongFloat round_long_double(LongFloat d) { - if (d >= 0) { - LongFloat q = floorl(d += 0.5); - if (q == d) { - int i = (int)fmodl(q, 10); - if (i & 1) { - return q - 1; - } - } - return q; - } else { - return -round_long_double(-d); - } -} -#endif - static void clasp_round(Real_sp dividend, Real_sp divisor, Integer_sp& quotient, Real_sp& remainder) { Integer_sp tru; Real_sp rem; clasp_truncate(dividend, divisor, tru, rem); // If they divide, no need to round - if (clasp_zerop(rem)) { + if (Number_O::zerop(rem)) { quotient = tru; remainder = rem; return; } - Real_sp threshold = gc::As_unsafe(clasp_divide(clasp_abs(divisor), clasp_make_fixnum(2))); - int c = clasp_number_compare(rem, threshold); - if (c > 0 || (c == 0 && clasp_oddp(tru))) { - if (clasp_minusp(divisor)) { - quotient = gc::As_unsafe(contagion_sub(tru, clasp_make_fixnum(1))); - remainder = gc::As_unsafe(contagion_add(rem, divisor)); + Real_sp threshold = gc::As_unsafe(Number_O::abs(divisor) / clasp_make_fixnum(2)); + int c = Number_O::compare(rem, threshold); + if (c > 0 || (c == 0 && Integer_O::oddp(tru))) { + if (Real_O::minusp(divisor)) { + quotient = gc::As_unsafe(tru - clasp_make_fixnum(1)); + remainder = rem + divisor; } else { quotient = gc::As_unsafe(clasp_one_plus(tru)); - remainder = gc::As_unsafe(contagion_sub(rem, divisor)); + remainder = gc::As_unsafe(rem - divisor); } return; } threshold = gc::As_unsafe(clasp_negate(threshold)); - c = clasp_number_compare(rem, threshold); - if (c < 0 || (c == 0 && clasp_oddp(tru))) { - if (clasp_minusp(divisor)) { + c = Number_O::compare(rem, threshold); + if (c < 0 || (c == 0 && Integer_O::oddp(tru))) { + if (Real_O::minusp(divisor)) { quotient = gc::As_unsafe(clasp_one_plus(tru)); - remainder = gc::As_unsafe(contagion_sub(rem, divisor)); + remainder = gc::As_unsafe(rem - divisor); } else { - quotient = gc::As_unsafe(contagion_sub(tru, clasp_make_fixnum(1))); - remainder = gc::As_unsafe(contagion_add(rem, divisor)); + quotient = gc::As_unsafe(tru - clasp_make_fixnum(1)); + remainder = rem + divisor; } return; } @@ -631,38 +512,52 @@ static void clasp_round(Real_sp dividend, Real_sp divisor, Integer_sp& quotient, remainder = rem; } +template Real_mv _round1(Float x) { + switch (std::fpclassify(x)) { + case FP_NAN: + feraiseexcept(FE_INVALID); + return Values(clasp_make_fixnum(0), Number_O::make_float(x)); + case FP_INFINITE: + return Values(clasp_make_fixnum(0), Number_O::make_float(x)); + default: { + auto r = std::fegetround(); + std::fesetround(FE_TONEAREST); + Float f = std::rint(x); + std::fesetround(r); + return Values(Integer_O::create(f), Number_O::make_float(x - f)); + } + } +} + Real_mv clasp_round1(Real_sp x) { - switch (clasp_t_of(x)) { - case number_Fixnum: - case number_Bignum: + if (x.fixnump() || x.isA()) return Values(x, clasp_make_fixnum(0)); - case number_Ratio: { - Ratio_sp rx = gc::As(x); - Integer_sp tv0; + + Ratio_sp rx = x.asOrNull(); + if (rx) { + Integer_sp v0; Real_sp tv1; - clasp_round(rx->numerator(), rx->denominator(), tv0, tv1); - return Values(tv0, Ratio_O::create(gc::As_unsafe(tv1), rx->denominator())); - } - case number_SingleFloat: { - float d = x.unsafe_single_float(); - float q = round_double(d); - return Values(_clasp_float_to_integer(q), clasp_make_single_float(d - q)); - } - case number_DoubleFloat: { - double d = gc::As_unsafe(x)->get(); - double q = round_double(d); - return Values(_clasp_double_to_integer(q), clasp_make_double_float(d - q)); + clasp_round(rx->numerator(), rx->denominator(), v0, tv1); + return Values(v0, Ratio_O::create(tv1.as_unsafe(), rx->denominator())); } + #ifdef CLASP_LONG_FLOAT - case number_LongFloat: { - LongFloat d = clasp_long_float(x); - LongFloat q = round_long_double(d); - return Values(_clasp_long_double_to_integer(q), clasp_make_long_float(d - q)); - } + if (x.isA()) + return _round1(x.as_unsafe()->get()); #endif - default: - ERROR_WRONG_TYPE_NTH_ARG(cl::_sym_round, 1, x, cl::_sym_Real_O); - } + + if (x.isA()) + return _round1(x.as_unsafe()->get()); + + if (x.single_floatp()) + return _round1(x.unsafe_single_float()); + +#ifdef CLASP_SHORT_FLOAT + if (x.short_floatp()) + return _round1(x.unsafe_short_float()); +#endif + + ERROR_WRONG_TYPE_NTH_ARG(cl::_sym_floor, 1, x, cl::_sym_Real_O); } Real_mv clasp_round2(Real_sp dividend, Real_sp divisor) { @@ -708,70 +603,39 @@ CL_DEFUN Real_sp cl__rem(Real_sp dividend, Real_sp divisor) { return rem; } +template Number_mv decode_float(Float x) { + if (std::isfinite(x)) { + int e = 0; + Float s = std::copysign(Float{1}, x); + x = std::frexp(std::abs(x), &e); + return Values(Number_O::make_float(x), clasp_make_fixnum(e), Number_O::make_float(s)); + } + SIMPLE_ERROR("Can't decode NaN or infinity {}", x); +} + CL_LAMBDA(x); CL_DECLARE(); CL_UNWIND_COOP(true); CL_DOCSTRING(R"dx(decodeFloat)dx"); DOCGROUP(clasp); CL_DEFUN Number_mv cl__decode_float(Float_sp x) { - int e = 0, s = 0; - NumberType tx = clasp_t_of(x); - float f; - switch (tx) { - case number_SingleFloat: { - f = x.unsafe_single_float(); - if (std::isfinite(f)) { - if (f >= 0.0) { - s = 1; - } else { - f = -f; - s = 0; - } - f = frexpf(f, &e); - x = clasp_make_single_float(f); - } else { - SIMPLE_ERROR("Can't decode NaN or infinity {}", _rep_(x)); - } - break; - } - case number_DoubleFloat: { - double d = gc::As_unsafe(x)->get(); - if (std::isfinite(d)) { - if (d >= 0.0) { - s = 1; - } else { - d = -d; - s = 0; - } - d = frexp(d, &e); - x = clasp_make_double_float(d); - } else { - SIMPLE_ERROR("Can't decode NaN or infinity {}", _rep_(x)); - } - break; - } #ifdef CLASP_LONG_FLOAT - case number_LongFloat: { - LongFloat d = clasp_long_float(x); - if (std::isfinite(d)) { - if (d >= 0.0) - s = 1; - else { - d = -d; - s = 0; - } - d = frexpl(d, &e); - x = clasp_make_long_float(d); - } else { - SIMPLE_ERROR("Can't decode NaN or infinity {}", _rep_(x)); - } - break; - } + if (x.isA()) + return decode_float(x.as_unsafe()->get()); #endif - default: - ERROR_WRONG_TYPE_NTH_ARG(cl::_sym_decodeFloat, 1, x, cl::_sym_float); - } - return Values(x, clasp_make_fixnum(e), clasp_make_single_float(s)); + + if (x.isA()) + return decode_float(x.as_unsafe()->get()); + + if (x.single_floatp()) + return decode_float(x.unsafe_single_float()); + +#ifdef CLASP_SHORT_FLOAT + if (x.short_floatp()) + return decode_float(x.unsafe_short_float()); +#endif + + ERROR_WRONG_TYPE_NTH_ARG(cl::_sym_decodeFloat, 1, x, cl::_sym_float); } CL_LAMBDA(x y); @@ -779,46 +643,42 @@ CL_DECLARE(); CL_UNWIND_COOP(true); CL_DOCSTRING(R"dx(scaleFloat)dx"); DOCGROUP(clasp); -CL_DEFUN Number_sp cl__scale_float(Number_sp x, Number_sp y) { - Fixnum k; - if (CLASP_FIXNUMP(y)) { - k = y.unsafe_fixnum(); - } else { - ERROR_WRONG_TYPE_NTH_ARG(cl::_sym_scaleFloat, 2, y, cl::_sym_fixnum); - } - switch (clasp_t_of(x)) { - case number_SingleFloat: - x = clasp_make_single_float(std::ldexp(x.unsafe_single_float(), k)); - break; - case number_DoubleFloat: - x = clasp_make_double_float(std::ldexp(gc::As_unsafe(x)->get(), k)); - break; +CL_DEFUN Number_sp cl__scale_float(Number_sp x, Fixnum y) { +#ifdef CLASP_SHORT_FLOAT + if (x.short_floatp()) + return ShortFloat_O::create(std::ldexp(x.unsafe_short_float(), y)); +#endif + if (x.single_floatp()) + return SingleFloat_dummy_O::create(std::ldexp(x.unsafe_single_float(), y)); + if (x.isA()) + return DoubleFloat_O::create(std::ldexp(x.as_unsafe()->get(), y)); #ifdef CLASP_LONG_FLOAT - case number_LongFloat: - x = clasp_make_long_float(std::ldexp(clasp_long_float(x), k)); - break; + if (x.isA()) + return LongFloat_O::create(std::ldexp(x.as_unsafe()->get(), y)); #endif - default: - ERROR_WRONG_TYPE_NTH_ARG(cl::_sym_scaleFloat, 1, x, cl::_sym_float); - } - return x; + ERROR_WRONG_TYPE_NTH_ARG(cl::_sym_scaleFloat, 1, x, cl::_sym_float); } Integer_sp cl__float_radix(Float_sp x) { return clasp_make_fixnum(FLT_RADIX); } -int clasp_signbit(Number_sp x) { - switch (clasp_t_of(x)) { - case number_SingleFloat: - return std::signbit(x.unsafe_single_float()); - case number_DoubleFloat: - return std::signbit(gc::As_unsafe(x)->get()); +bool clasp_signbit(Number_sp x) { #ifdef CLASP_LONG_FLOAT - case number_LongFloat: - return signbit(clasp_long_float(x)); + if (x.isA()) + return std::signbit(x.as_unsafe()->get()); #endif - default: - ERROR_WRONG_TYPE_NTH_ARG(cl::_sym_floatSign, 1, x, cl::_sym_float); - } + + if (x.isA()) + return std::signbit(x.as_unsafe()->get()); + + if (x.single_floatp()) + return std::signbit(x.unsafe_single_float()); + +#ifdef CLASP_SHORT_FLOAT + if (x.short_floatp()) + return std::signbit(x.unsafe_short_float()); +#endif + + ERROR_WRONG_TYPE_NTH_ARG(cl::_sym_floatSign, 1, x, cl::_sym_float); } CL_LAMBDA(x &optional (y nil yp)); @@ -826,34 +686,41 @@ CL_DECLARE(); CL_UNWIND_COOP(true); CL_DOCSTRING(R"dx(floatSign)dx"); DOCGROUP(clasp); -CL_DEFUN Float_sp cl__float_sign(Float_sp x, T_sp oy, T_sp yp) { - Float_sp y = yp.nilp() ? cl__float(clasp_make_fixnum(1), x) : gc::As(oy); - int negativep = clasp_signbit(x); - switch (clasp_t_of(y)) { - case number_SingleFloat: { - float f = y.unsafe_single_float(); - if (std::signbit(f) != negativep) - y = clasp_make_single_float(-f); - break; - } - case number_DoubleFloat: { - double f = gc::As_unsafe(y)->get(); - if (std::signbit(f) != negativep) - y = clasp_make_double_float(-f); - break; - } +CL_DEFUN Float_sp cl__float_sign(Float_sp x, T_sp oy, bool yp) { + if (!yp) { #ifdef CLASP_LONG_FLOAT - case number_LongFloat: { - LongFloat f = clasp_long_float(y); - if (std::signbit(f) != negativep) - y = clasp_make_long_float(-f); - break; - } + if (x.isA()) + return Number_O::make_float(std::copysign(long_float_t{1}, x.as_unsafe()->get())); +#endif + if (x.isA()) + return Number_O::make_float(std::copysign(double_float_t{1}, x.as_unsafe()->get())); + if (x.single_floatp()) + return Number_O::make_float(std::copysign(single_float_t{1}, x.unsafe_single_float())); +#ifdef CLASP_SHORT_FLOAT + if (x.short_floatp()) + return Number_O::make_float(std::copysign(short_float_t{1}, x.unsafe_short_float())); #endif - default: - ERROR_WRONG_TYPE_NTH_ARG(cl::_sym_floatSign, 2, y, cl::_sym_float); } - return y; + + int sign = clasp_signbit(x) ? -1 : 1; + + if (oy.single_floatp()) + return Number_O::make_float(std::copysign(oy.unsafe_single_float(), sign)); + +#ifdef CLASP_SHORT_FLOAT + if (oy.short_floatp()) + return Number_O::make_float(std::copysign(oy.unsafe_short_float(), sign)); +#endif + + if (oy.isA()) + return Number_O::make_float(std::copysign(oy.as_unsafe()->get(), sign)); + +#ifdef CLASP_LONG_FLOAT + if (oy.isA()) + return Number_O::make_float(std::copysign(oy.as_unsafe()->get(), sign)); +#endif + + ERROR_WRONG_TYPE_NTH_ARG(cl::_sym_floatSign, 2, oy, cl::_sym_float); } CL_LAMBDA(x); @@ -862,23 +729,30 @@ CL_UNWIND_COOP(true); CL_DOCSTRING(R"dx(floatDigits)dx"); DOCGROUP(clasp); CL_DEFUN Integer_sp cl__float_digits(Float_sp x) { - Integer_sp ix(nil()); - switch (clasp_t_of(x)) { - case number_SingleFloat: - ix = clasp_make_fixnum(FLT_MANT_DIG); - break; - case number_DoubleFloat: - ix = clasp_make_fixnum(DBL_MANT_DIG); - break; +#ifdef CLASP_SHORT_FLOAT + if (x.short_floatp()) + return clasp_make_fixnum(std::numeric_limits::digits); +#endif + if (x.single_floatp()) + return clasp_make_fixnum(std::numeric_limits::digits); + if (x.isA()) + return clasp_make_fixnum(std::numeric_limits::digits); #ifdef CLASP_LONG_FLOAT - case number_LongFloat: - ix = clasp_make_fixnum(LDBL_MANT_DIG); - break; + if (x.isA()) + return clasp_make_fixnum(std::numeric_limits::digits); #endif + ERROR_WRONG_TYPE_NTH_ARG(cl::_sym_floatPrecision, 1, x, cl::_sym_float); +} + +template size_t float_precision(Float f) { + switch (std::fpclassify(f)) { + case FP_ZERO: + return 0; + case FP_SUBNORMAL: + return 1 - std::numeric_limits::min_exponent + std::ilogb(f) + std::numeric_limits::digits; default: - ERROR_WRONG_TYPE_NTH_ARG(cl::_sym_floatDigits, 1, x, cl::_sym_float); + return std::numeric_limits::digits; } - return ix; } CL_LAMBDA(value); @@ -887,59 +761,19 @@ CL_UNWIND_COOP(true); CL_DOCSTRING(R"dx(floatPrecision)dx"); DOCGROUP(clasp); CL_DEFUN Integer_sp cl__float_precision(Float_sp x) { - int precision = 0; - switch (clasp_t_of(x)) { - case number_SingleFloat: { - float f = x.unsafe_single_float(); - if (f == 0.0) { - precision = 0; - } else { - int exp; - frexpf(f, &exp); - if (exp >= FLT_MIN_EXP) { - precision = FLT_MANT_DIG; - } else { - precision = FLT_MANT_DIG - (FLT_MIN_EXP - exp); - } - } - break; - } - case number_DoubleFloat: { - double f = gc::As_unsafe(x)->get(); - if (f == 0.0) { - precision = 0; - } else { - int exp; - frexp(f, &exp); - if (exp >= DBL_MIN_EXP) { - precision = DBL_MANT_DIG; - } else { - precision = DBL_MANT_DIG - (DBL_MIN_EXP - exp); - } - } - break; - } +#ifdef CLASP_SHORT_FLOAT + if (x.short_floatp()) + return clasp_make_fixnum(float_precision(x.unsafe_short_float())); +#endif + if (x.single_floatp()) + return clasp_make_fixnum(float_precision(x.unsafe_single_float())); + if (x.isA()) + return clasp_make_fixnum(float_precision(x.as_unsafe()->get())); #ifdef CLASP_LONG_FLOAT - case number_LongFloat: { - LongFloat f = clasp_long_float(x); - if (f == 0.0) { - precision = 0; - } else { - int exp; - frexp(f, &exp); - if (exp >= LDBL_MIN_EXP) { - precision = LDBL_MANT_DIG; - } else { - precision = LDBL_MANT_DIG - (LDBL_MIN_EXP - exp); - } - } - break; - } + if (x.isA()) + return clasp_make_fixnum(float_precision(x.as_unsafe()->get())); #endif - default: - ERROR_WRONG_TYPE_NTH_ARG(cl::_sym_floatPrecision, 1, x, cl::_sym_float); - } - return clasp_make_fixnum(precision); + ERROR_WRONG_TYPE_NTH_ARG(cl::_sym_floatPrecision, 1, x, cl::_sym_float); } template inline Real_mv integer_decode_float(Float f) { @@ -949,18 +783,20 @@ template inline Real_mv integer_decode_float(Float f) { switch (std::fpclassify(f)) { case FP_INFINITE: feraiseexcept(FE_INVALID); - q = float_convert::to_quadruple(std::signbit(f) ? std::numeric_limits::min() : std::numeric_limits::max()); + q = float_convert::float_to_quadruple(std::signbit(f) ? std::numeric_limits::min() + : std::numeric_limits::max()); break; case FP_NAN: feraiseexcept(FE_INVALID); - q = float_convert::to_quadruple(std::signbit(f) ? Float{-0.0} : Float{0.0}); + q = float_convert::float_to_quadruple(std::signbit(f) ? Float{-0.0} : Float{0.0}); break; default: - q = float_convert::to_quadruple(f); + q = float_convert::float_to_quadruple(f); break; } - return Values(Integer_O::create(q.significand), clasp_make_fixnum(q.exponent), clasp_make_fixnum(q.sign)); + return Values(Integer_O::create((typename float_convert::uint_t)q.significand), clasp_make_fixnum(q.exponent), + clasp_make_fixnum(q.sign)); } CL_LAMBDA(x); @@ -969,18 +805,19 @@ CL_UNWIND_COOP(true); CL_DOCSTRING(R"dx(integer_decode_float)dx"); DOCGROUP(clasp); CL_DEFUN Real_mv cl__integer_decode_float(Float_sp x) { - switch (clasp_t_of(x)) { -#ifdef CLASP_LONG_FLOAT - case number_LongFloat: - return integer_decode_float(gc::As_unsafe(x)->get()); +#ifdef CLASP_SHORT_FLOAT + if (x.short_floatp()) + return integer_decode_float(x.unsafe_short_float()); #endif - case number_DoubleFloat: - return integer_decode_float(gc::As_unsafe(x)->get()); - case number_SingleFloat: + if (x.single_floatp()) return integer_decode_float(x.unsafe_single_float()); - default: - ERROR_WRONG_TYPE_NTH_ARG(cl::_sym_integer_decode_float, 1, x, cl::_sym_float); - } + if (x.isA()) + return integer_decode_float(x.as_unsafe()->get()); +#ifdef CLASP_LONG_FLOAT + if (x.isA()) + return integer_decode_float(x.as_unsafe()->get()); +#endif + ERROR_WRONG_TYPE_NTH_ARG(cl::_sym_integer_decode_float, 1, x, cl::_sym_float); } CL_LAMBDA(r &optional (i 0)); @@ -990,54 +827,25 @@ CL_DOCSTRING(R"dx(complex)dx"); DOCGROUP(clasp); CL_DEFUN Complex_sp cl__complex(Real_sp r, Real_sp i) { return gc::As_unsafe(clasp_make_complex(r, i)); } +Real_sp DoubleFloat_O::imagpart_() const { return create(std::copysign(double_float_t{0.0}, _Value)); } + +#ifdef CLASP_LONG_FLOAT +Real_sp LongFloat_O::imagpart_() const { return create(std::copysign(long_float_t{0.0}, _Value)); } +#endif + CL_LAMBDA(x); CL_DECLARE(); CL_UNWIND_COOP(true); CL_DOCSTRING(R"dx(realpart)dx"); DOCGROUP(clasp); -CL_DEFUN Real_sp cl__realpart(Number_sp x) { - switch (clasp_t_of(x)) { - case number_Fixnum: - case number_Bignum: - case number_Ratio: - case number_SingleFloat: - case number_DoubleFloat: -#ifdef CLASP_LONG_FLOAT - case number_LongFloat: -#endif - return gc::As_unsafe(x); - case number_Complex: - return gc::As_unsafe(x)->real(); - default: - ERROR_WRONG_TYPE_NTH_ARG(cl::_sym_realpart, 1, x, cl::_sym_Number_O); - } -} +CL_DEFUN Real_sp cl__realpart(Number_sp x) { return Number_O::realpart(x); } CL_LAMBDA(x); CL_DECLARE(); CL_UNWIND_COOP(true); CL_DOCSTRING(R"dx(imagpart)dx"); DOCGROUP(clasp); -CL_DEFUN Real_sp cl__imagpart(Number_sp x) { - switch (clasp_t_of(x)) { - case number_Fixnum: - case number_Bignum: - case number_Ratio: - return clasp_make_fixnum(0); - case number_SingleFloat: - return clasp_make_single_float((float)0 * x.unsafe_single_float()); - case number_DoubleFloat: - return DoubleFloat_O::create((float)0 * gc::As_unsafe(x)->get()); -#ifdef CLASP_LONG_FLOAT - case number_LongFloat: - return LongFloat_O::create((float)0 * clasp_long_float(x)); -#endif - case number_Complex: - return gc::As_unsafe(x)->imaginary(); - default: - ERROR_WRONG_TYPE_NTH_ARG(cl::_sym_imagpart, 1, x, cl::_sym_Number_O); - } -} +CL_DEFUN Real_sp cl__imagpart(Number_sp x) { return Number_O::imagpart(x); } SYMBOL_EXPORT_SC_(ClPkg, float); SYMBOL_EXPORT_SC_(ClPkg, numerator); diff --git a/src/core/numbers.cc b/src/core/numbers.cc index 64b413ea67..3c88621c38 100644 --- a/src/core/numbers.cc +++ b/src/core/numbers.cc @@ -41,7 +41,6 @@ THE SOFTWARE. #include #include #include -#include #include #include #include @@ -72,64 +71,40 @@ core::Fixnum not_fixnum_error(core::T_sp o) { TYPE_ERROR(o, cl::_sym_fixnum); } void clasp_report_divide_by_zero(Number_sp x) { ERROR_DIVISION_BY_ZERO(clasp_make_fixnum(1), x); } Number_sp clasp_make_complex(Real_sp r, Real_sp i) { - // need to check whether i is 0 - // A bignum better not be 0 - // if realpart is a rational and imagpart is the rational number zero, the result of complex is realpart, a rational. if (i.fixnump() && cl__rationalp(r)) { - Fixnum fn = i.unsafe_fixnum(); - if (fn == 0) + if (i.unsafe_fixnum() == 0) return r; - else - return Complex_O::create(r, i); - } - // If imagpart is not supplied, the imaginary part is a zero of the same type as realpart; - // perhaps need to distinguish better whether i is supplied or not - if (cl__floatp(r) && i.fixnump() && clasp_zerop(i)) { - if (r.single_floatp()) - i = clasp_make_single_float(0.0); - else if (core__double_float_p(r)) - i = DoubleFloat_O::create(0.0); - else if (core__long_float_p(r)) - i = LongFloat_O::create(0.0l); - // short floats are not really implemented - } - // If either realpart or imagpart is a float, the non-float is converted to a float before the complex is created. - // does that mean, I need to distinguish single and double-float? PDietz seem to assume so - else if (cl__floatp(r) && !cl__floatp(i)) { - if (r.single_floatp()) - i = cl__float(i, clasp_make_single_float(1.0)); - else - i = cl__float(i, DoubleFloat_O::create(1.0)); - } else if (cl__floatp(i) && !cl__floatp(r)) { - if (i.single_floatp()) - r = cl__float(r, clasp_make_single_float(1.0)); - else - r = cl__float(r, DoubleFloat_O::create(1.0)); - } else if (cl__floatp(i) && cl__floatp(r)) { - // the highest type of both wins single -> double -> long - if (r.single_floatp()) { - if (!(i.single_floatp())) { - // r should be of type of i - if (core__double_float_p(i)) - r = DoubleFloat_O::create((double)r.unsafe_single_float()); - else - r = LongFloat_O::create((long)r.unsafe_single_float()); - } - } else if (core__double_float_p(r)) { - if (!(core__double_float_p(i))) { - if (core__long_float_p(i)) - r = LongFloat_O::create(clasp_to_long_float(r)); - else - i = DoubleFloat_O::create((double)i.unsafe_single_float()); - } - } else if (core__long_float_p(r)) - if (!(core__long_float_p(i))) { - if (i.single_floatp()) - i = DoubleFloat_O::create((double)i.unsafe_single_float()); - else - i = LongFloat_O::create(clasp_to_long_float(i)); - } + return Complex_O::create(r, i); + } + + if (!cl__floatp(r) && !cl__floatp(i)) + return Complex_O::create(r, i); + + if (r.single_floatp()) { + if (i.isA()) + return Complex_O::create(DoubleFloat_O::coerce(r), i); + if (i.isA()) + return Complex_O::create(LongFloat_O::coerce(r), i); + return Complex_O::create(r, SingleFloat_dummy_O::coerce(i)); } + + if (r.isA()) { + if (i.isA()) + return Complex_O::create(LongFloat_O::coerce(r), i); + return Complex_O::create(r, DoubleFloat_O::coerce(i)); + } + + if (r.isA()) { + return Complex_O::create(r, LongFloat_O::coerce(i)); + } + + if (i.single_floatp()) + return Complex_O::create(SingleFloat_dummy_O::coerce(r), i); + if (i.isA()) + return Complex_O::create(DoubleFloat_O::coerce(r), i); + if (i.isA()) + return Complex_O::create(LongFloat_O::coerce(r), i); + return Complex_O::create(r, i); } @@ -138,7 +113,35 @@ CL_DECLARE(); CL_UNWIND_COOP(true); CL_DOCSTRING(R"dx(zerop)dx"); DOCGROUP(clasp); -CL_DEFUN bool cl__zerop(Number_sp num) { return clasp_zerop(num); } +CL_DEFUN bool cl__zerop(Number_sp num) { return Number_O::zerop(num); } + +CL_LAMBDA(num); +CL_DECLARE(); +CL_UNWIND_COOP(true); +CL_DOCSTRING(R"dx(minusp)dx"); +DOCGROUP(clasp); +CL_DEFUN bool cl__minusp(Real_sp num) { return Real_O::minusp(num); } + +CL_LAMBDA(num); +CL_DECLARE(); +CL_UNWIND_COOP(true); +CL_DOCSTRING(R"dx(plusp)dx"); +DOCGROUP(clasp); +CL_DEFUN bool cl__plusp(Real_sp num) { return Real_O::plusp(num); } + +CL_LAMBDA(num); +CL_DECLARE(); +CL_UNWIND_COOP(true); +CL_DOCSTRING(R"dx(evenp)dx"); +DOCGROUP(clasp); +CL_DEFUN bool cl__evenp(Integer_sp num) { return Integer_O::evenp(num); } + +CL_LAMBDA(num); +CL_DECLARE(); +CL_UNWIND_COOP(true); +CL_DOCSTRING(R"dx(oddp)dx"); +DOCGROUP(clasp); +CL_DEFUN bool cl__oddp(Integer_sp num) { return Integer_O::oddp(num); } CL_LAMBDA(); CL_DECLARE(); @@ -152,14 +155,14 @@ CL_DEFUN Fixnum_sp core__fixnum_number_of_bits() { Real_sp clasp_max2(Real_sp x, Real_sp y) { Real_sp max = x; - if (clasp_number_compare(max, y) < 0) + if (Number_O::compare(max, y) < 0) max = y; return max; } Real_sp clasp_min2(Real_sp x, Real_sp y) { Real_sp min = x; - if (clasp_number_compare(min, y) > 0) + if (Number_O::compare(min, y) > 0) min = y; return min; } @@ -170,7 +173,7 @@ CL_UNWIND_COOP(true); CL_DOCSTRING(R"dx(min)dx"); DOCGROUP(clasp); CL_DEFUN Real_sp cl__min(Real_sp min, List_sp nums) { - /* INV: type check occurs in clasp_number_compare() for the rest of + /* INV: type check occurs in Number_O::compare() for the rest of numbers, but for the first argument it's due to the Real_sp decl above. */ for (auto cur : nums) { @@ -202,433 +205,198 @@ CL_DEFUN Number_sp two_arg__PLUS_FF(Fixnum fa, Fixnum fb) { return Integer_O::cr CL_NAME("TWO-ARG-+"); CL_UNWIND_COOP(true); DOCGROUP(clasp); -CL_DEFUN Number_sp contagion_add(Number_sp na, Number_sp nb) { - MATH_DISPATCH_BEGIN(na, nb) { - case_Fixnum_v_Fixnum: - return two_arg__PLUS_FF(na.unsafe_fixnum(), nb.unsafe_fixnum()); - case_Fixnum_v_Bignum: - return core__next_fadd(gc::As_unsafe(nb), na.unsafe_fixnum()); - case_Fixnum_v_Ratio: - case_Bignum_v_Ratio : { - // NOTE: All of the numbers are either fixnums or bignums, - // so this could be more efficient maybe. - Ratio_sp rat = gc::As_unsafe(nb); - Integer_sp den = rat->denominator(); - Integer_sp new_num = gc::As_unsafe(contagion_add(rat->numerator(), contagion_mul(na, den))); - // result is a ratio, not an integer. - return Ratio_O::create(new_num, den); - } - case_Fixnum_v_SingleFloat : { return clasp_make_single_float(clasp_to_float(na) + clasp_to_float(nb)); } - case_Fixnum_v_DoubleFloat : { return DoubleFloat_O::create(clasp_to_double(na) + clasp_to_double(nb)); } - case_Bignum_v_Fixnum: - return core__next_fadd(gc::As_unsafe(na), nb.unsafe_fixnum()); - case_Bignum_v_Bignum: - return core__next_add(gc::As_unsafe(na), gc::As_unsafe(nb)); - case_Bignum_v_SingleFloat: - case_Ratio_v_SingleFloat : { return clasp_make_single_float(clasp_to_float(na) + clasp_to_float(nb)); } - case_Bignum_v_DoubleFloat: - case_Ratio_v_DoubleFloat : { return DoubleFloat_O::create(clasp_to_double(na) + clasp_to_double(nb)); } - case_Ratio_v_Fixnum: - case_Ratio_v_Bignum : { - Ratio_sp rat = gc::As_unsafe(na); - Integer_sp den = rat->denominator(); - Integer_sp new_num = gc::As_unsafe(contagion_add(rat->numerator(), contagion_mul(nb, den))); - // result is a ratio, not an integer. - return Ratio_O::create(new_num, den); - } - case_Ratio_v_Ratio : { - Ratio_sp ra = gc::As(na); - Ratio_sp rb = gc::As(nb); - // ra.num/ra.den + rb.num/rb.den = (ra.num*rb.den+rb.num*ra.den)/ra.den*rb.den - Number_sp n1 = contagion_mul(ra->numerator(), rb->denominator()); - Number_sp n2 = contagion_mul(ra->denominator(), rb->numerator()); - Number_sp d = contagion_mul(ra->denominator(), rb->denominator()); - Number_sp n = contagion_add(n1, n2); - return Rational_O::create(gc::As_unsafe(n), gc::As_unsafe(d)); - } - case_SingleFloat_v_Fixnum: - case_SingleFloat_v_Bignum: - case_SingleFloat_v_Ratio: - return clasp_make_single_float(clasp_to_float(na) + clasp_to_float(nb)); - case_SingleFloat_v_SingleFloat: - return clasp_make_single_float(clasp_to_float(na) + clasp_to_float(nb)); - case_SingleFloat_v_DoubleFloat: - case_DoubleFloat_v_Fixnum: - case_DoubleFloat_v_Bignum: - case_DoubleFloat_v_Ratio: - case_DoubleFloat_v_SingleFloat: - case_DoubleFloat_v_DoubleFloat: - return DoubleFloat_O::create(clasp_to_double(na) + clasp_to_double(nb)); -#ifdef CLASP_LONG_FLOAT - case_Fixnum_v_LongFloat: - case_Ratio_v_LongFloat: - case_SingleFloat_v_LongFloat: - case_DoubleFloat_v_LongFloat: - case_LongFloat_v_Fixnum: - case_LongFloat_v_Ratio: - case_LongFloat_v_SingleFloat: - case_LongFloat_v_DoubleFloat: - case_LongFloat_v_LongFloat: - return LongFloat_O::create(na->as_long_float() + nb->as_long_float()); - case_Complex_v_LongFloat: -#endif // CLASP_LONG_FLOAT - case_Complex_v_Fixnum: - case_Complex_v_Ratio: - case_Complex_v_Bignum: - case_Complex_v_SingleFloat: - case_Complex_v_DoubleFloat : { - Number_sp aux = na; - na = nb; - nb = aux; - goto Complex_v_Y; - } - case_Fixnum_v_Complex: - case_Bignum_v_Complex: - case_Ratio_v_Complex: - case_SingleFloat_v_Complex: - case_DoubleFloat_v_Complex: +CL_DEFUN Number_sp Number_O::add_nn(Number_sp na, Number_sp nb) { + Complex_sp ca = na.asOrNull(), cb = nb.asOrNull(); + if (ca && cb) + return clasp_make_complex(ca->real() + cb->real(), ca->imaginary() + cb->imaginary()); + if (ca) + return clasp_make_complex(ca->real() + nb.as_unsafe(), ca->imaginary()); + if (cb) + return clasp_make_complex(na.as_unsafe() + cb->real(), cb->imaginary()); + #ifdef CLASP_LONG_FLOAT - case_LongFloat_v_Complex: -#endif - Complex_v_Y: - return clasp_make_complex(gc::As(contagion_add(na, gc::As(nb)->real())), - gc::As(nb)->imaginary()); - case_Complex_v_Complex : { - Real_sp r = gc::As(contagion_add(gc::As(na)->real(), gc::As(nb)->real())); - Real_sp i = gc::As(contagion_add(gc::As(na)->imaginary(), gc::As(nb)->imaginary())); - return clasp_make_complex(r, i); - } break; - default: - not_comparable_error(na, nb); - }; - MATH_DISPATCH_END(); + if (na.isA() || nb.isA()) + return LongFloat_O::create(as_long_float(na) + as_long_float(nb)); +#endif + + if (na.isA() || nb.isA()) + return DoubleFloat_O::create(as_double_float(na) + as_double_float(nb)); + + if (na.single_floatp() || nb.single_floatp()) + return SingleFloat_dummy_O::create(as_single_float(na) + as_single_float(nb)); + +#ifdef CLASP_SHORT_FLOAT + if (na.short_floatp() || nb.short_floatp()) + return ShortFloat_O::create(as_short_float(na) + as_short_float(nb)); +#endif + + Ratio_sp ra = na.asOrNull(), rb = nb.asOrNull(); + if (ra && rb) + return Rational_O::create(ra->numerator() * rb->denominator() + ra->denominator() * rb->numerator(), + ra->denominator() * rb->denominator()); + if (ra) + return Ratio_O::create(ra->numerator() + nb.as_unsafe() * ra->denominator(), ra->denominator()); + if (rb) + return Ratio_O::create(na.as_unsafe() * rb->denominator() + rb->numerator(), rb->denominator()); + + Bignum_sp ba = na.asOrNull(), bb = nb.asOrNull(); + if (ba && bb) + return add_bb(ba, bb); + if (ba) + return add_bx(ba, nb.unsafe_fixnum()); + if (bb) + return add_bx(bb, na.unsafe_fixnum()); + + return Integer_O::create(na.unsafe_fixnum() + nb.unsafe_fixnum()); }; CL_NAME("TWO-ARG--"); CL_UNWIND_COOP(true); DOCGROUP(clasp); -CL_DEFUN Number_sp contagion_sub(Number_sp na, Number_sp nb) { - MATH_DISPATCH_BEGIN(na, nb) { - case_Fixnum_v_Fixnum : { - Fixnum fa = na.unsafe_fixnum(); - Fixnum fb = nb.unsafe_fixnum(); - return Integer_O::create(static_cast(fa - fb)); - } - case_Fixnum_v_Ratio: - case_Bignum_v_Ratio : { - // x - a/b = xb/b - a/b = (xb-a)/b - Ratio_sp rb = gc::As(nb); - Number_sp n1 = contagion_mul(na, rb->denominator()); - Number_sp n = contagion_sub(n1, rb->numerator()); - return Ratio_O::create(gc::As_unsafe(n), rb->denominator()); - } - case_Fixnum_v_SingleFloat : { return clasp_make_single_float(clasp_to_float(na) - clasp_to_float(nb)); } - case_Fixnum_v_DoubleFloat : { return DoubleFloat_O::create(clasp_to_double(na) - clasp_to_double(nb)); } - case_Ratio_v_SingleFloat: - case_Bignum_v_SingleFloat : { return clasp_make_single_float(clasp_to_float(na) - clasp_to_float(nb)); } - case_Ratio_v_DoubleFloat: - case_Bignum_v_DoubleFloat : { return DoubleFloat_O::create(clasp_to_double(na) - clasp_to_double(nb)); } - case_Fixnum_v_Bignum: - return core__next_fsub(na.unsafe_fixnum(), gc::As_unsafe(nb)); - case_Bignum_v_Fixnum: - return core__next_fadd(gc::As_unsafe(na), -(nb.unsafe_fixnum())); - case_Bignum_v_Bignum: - return core__next_sub(gc::As_unsafe(na), gc::As_unsafe(nb)); - case_Ratio_v_Fixnum: - case_Ratio_v_Bignum : { - // a/b - x = a/b - xb/b = (a-xb)/b - Ratio_sp ra = gc::As(na); - Number_sp n2 = contagion_mul(nb, ra->denominator()); - Number_sp n = contagion_sub(ra->numerator(), n2); - return Ratio_O::create(gc::As_unsafe(n), ra->denominator()); - } - case_Ratio_v_Ratio : { - // a/b - c/d = (ad-bc)/bd - Ratio_sp ra = gc::As(na); - Ratio_sp rb = gc::As(nb); - Number_sp n1 = contagion_mul(ra->numerator(), rb->denominator()); - Number_sp n2 = contagion_mul(ra->denominator(), rb->numerator()); - Number_sp n = contagion_sub(n1, n2); - Number_sp d = contagion_mul(ra->denominator(), rb->denominator()); - return Rational_O::create(gc::As_unsafe(n), gc::As_unsafe(d)); - } - case_SingleFloat_v_Fixnum: - case_SingleFloat_v_Bignum: - case_SingleFloat_v_Ratio: - return clasp_make_single_float(clasp_to_float(na) - clasp_to_float(nb)); - case_SingleFloat_v_SingleFloat: - return clasp_make_single_float(clasp_to_float(na) - clasp_to_float(nb)); - case_SingleFloat_v_DoubleFloat: - case_DoubleFloat_v_Fixnum: - case_DoubleFloat_v_Bignum: - case_DoubleFloat_v_Ratio: - case_DoubleFloat_v_SingleFloat: - case_DoubleFloat_v_DoubleFloat: - return DoubleFloat_O::create(clasp_to_double(na) - clasp_to_double(nb)); +CL_DEFUN Number_sp Number_O::sub_nn(Number_sp na, Number_sp nb) { + Complex_sp ca = na.asOrNull(), cb = nb.asOrNull(); + if (ca && cb) + return clasp_make_complex(ca->real() - cb->real(), ca->imaginary() - cb->imaginary()); + if (ca) + return clasp_make_complex(ca->real() - nb.as_unsafe(), ca->imaginary()); + if (cb) + return clasp_make_complex(na.as_unsafe() - cb->real(), -cb->imaginary()); + #ifdef CLASP_LONG_FLOAT - case_Fixnum_v_LongFloat: - case_Ratio_v_LongFloat: - case_SingleFloat_v_LongFloat: - case_DoubleFloat_v_LongFloat: - case_LongFloat_v_Fixnum: - case_LongFloat_v_Ratio: - case_LongFloat_v_SingleFloat: - case_LongFloat_v_DoubleFloat: - case_LongFloat_v_LongFloat: - return LongFloat_O::create(na->as_long_float() - nb->as_long_float()); -#endif - case_Complex_v_LongFloat: - case_Complex_v_Fixnum: - case_Complex_v_Ratio: - case_Complex_v_Bignum: - case_Complex_v_SingleFloat: - case_Complex_v_DoubleFloat : { - return clasp_make_complex(gc::As(contagion_sub(gc::As(na)->real(), nb)), - gc::As(na)->imaginary()); - } - case_Fixnum_v_Complex: - case_Bignum_v_Complex: - case_Ratio_v_Complex: - case_SingleFloat_v_Complex: - case_DoubleFloat_v_Complex: - case_LongFloat_v_Complex: - return clasp_make_complex(gc::As(contagion_sub(na, gc::As(nb)->real())), - gc::As(clasp_negate(gc::As(nb)->imaginary()))); - case_Complex_v_Complex : { - Real_sp r = gc::As(contagion_sub(gc::As(na)->real(), gc::As(nb)->real())); - Real_sp i = gc::As(contagion_sub(gc::As(na)->imaginary(), gc::As(nb)->imaginary())); - return clasp_make_complex(r, i); - } break; - default: - not_comparable_error(na, nb); - }; - MATH_DISPATCH_END(); + if (na.isA() || nb.isA()) + return LongFloat_O::create(as_long_float(na) - as_long_float(nb)); +#endif + + if (na.isA() || nb.isA()) + return DoubleFloat_O::create(as_double_float(na) - as_double_float(nb)); + + if (na.single_floatp() || nb.single_floatp()) + return SingleFloat_dummy_O::create(as_single_float(na) - as_single_float(nb)); + +#ifdef CLASP_SHORT_FLOAT + if (na.short_floatp() || nb.short_floatp()) + return ShortFloat_O::create(as_short_float(na) - as_short_float(nb)); +#endif + + Ratio_sp ra = na.asOrNull(), rb = nb.asOrNull(); + if (ra && rb) + return Rational_O::create(ra->numerator() * rb->denominator() - ra->denominator() * rb->numerator(), + ra->denominator() * rb->denominator()); + if (ra) + return Ratio_O::create(ra->numerator() - nb.as_unsafe() * ra->denominator(), ra->denominator()); + if (rb) + return Ratio_O::create(na.as_unsafe() * rb->denominator() - rb->numerator(), rb->denominator()); + + Bignum_sp ba = na.asOrNull(), bb = nb.asOrNull(); + if (ba && bb) + return sub_bb(ba, bb); + if (ba) + return add_bx(ba, -nb.unsafe_fixnum()); + if (bb) + return sub_xb(na.unsafe_fixnum(), bb); + + return Integer_O::create(na.unsafe_fixnum() - nb.unsafe_fixnum()); } CL_NAME("TWO-ARG-*"); CL_UNWIND_COOP(true); DOCGROUP(clasp); -CL_DEFUN Number_sp contagion_mul(Number_sp na, Number_sp nb) { - MATH_DISPATCH_BEGIN(na, nb) { - case_Fixnum_v_Fixnum : { - // We want to detect when Fixnum * Fixnum multiplication will overflow and only then use bignum arithmetic. - // But C++ doesn't give us a way to do that - so we use the __builtin_mul_overflow clang builtin. - // It will return false if there is no overflow and the multiplication result will be in fr. - // The return value fr may over - // If it doesn't overflow - then this will be faster than always using bignum arithmetic. - Fixnum fa = na.unsafe_fixnum(); - Fixnum fb = nb.unsafe_fixnum(); - Fixnum fr; - bool overflow = __builtin_mul_overflow(fa, fb, &fr); - if (!overflow) - return Integer_O::create(fr); - return core__mul_fixnums(fa, fb); - } - case_Fixnum_v_Bignum: - return core__next_fmul(gc::As_unsafe(nb), na.unsafe_fixnum()); - case_Fixnum_v_Ratio: - case_Bignum_v_Ratio : { - Ratio_sp rat = gc::As_unsafe(nb); - Integer_sp new_num = gc::As_unsafe(contagion_mul(na, rat->numerator())); - return Rational_O::create(new_num, rat->denominator()); - } - case_Fixnum_v_SingleFloat : { return clasp_make_single_float(clasp_to_float(na) * clasp_to_float(nb)); } - case_Fixnum_v_DoubleFloat : { return DoubleFloat_O::create(clasp_to_double(na) * clasp_to_double(nb)); } - case_Bignum_v_Fixnum: - return core__next_fmul(gc::As_unsafe(na), nb.unsafe_fixnum()); - case_Bignum_v_Bignum: - return core__next_mul(gc::As_unsafe(na), gc::As_unsafe(nb)); - case_Bignum_v_SingleFloat: - case_Ratio_v_SingleFloat : { return clasp_make_single_float(clasp_to_float(na) * clasp_to_float(nb)); } - case_Bignum_v_DoubleFloat: - case_Ratio_v_DoubleFloat : { return DoubleFloat_O::create(clasp_to_double(na) * clasp_to_double(nb)); } - case_Ratio_v_Fixnum: - case_Ratio_v_Bignum : { - Ratio_sp rat = gc::As_unsafe(na); - Integer_sp new_num = gc::As_unsafe(contagion_mul(nb, rat->numerator())); - return Rational_O::create(new_num, rat->denominator()); - } - case_Ratio_v_Ratio : { - Ratio_sp ra = gc::As(na); - Ratio_sp rb = gc::As(nb); - Number_sp num = contagion_mul(ra->numerator(), rb->numerator()); - Number_sp den = contagion_mul(ra->denominator(), rb->denominator()); - return Rational_O::create(gc::As_unsafe(num), gc::As_unsafe(den)); - } - case_SingleFloat_v_Fixnum: - case_SingleFloat_v_Bignum: - case_SingleFloat_v_Ratio: - case_SingleFloat_v_SingleFloat: - return clasp_make_single_float(clasp_to_float(na) * clasp_to_float(nb)); - case_SingleFloat_v_DoubleFloat: - case_DoubleFloat_v_Fixnum: - case_DoubleFloat_v_Bignum: - case_DoubleFloat_v_Ratio: - case_DoubleFloat_v_SingleFloat: - case_DoubleFloat_v_DoubleFloat: - return DoubleFloat_O::create(clasp_to_double(na) * clasp_to_double(nb)); +CL_DEFUN Number_sp Number_O::mul_nn(Number_sp na, Number_sp nb) { + Complex_sp ca = na.asOrNull(), cb = nb.asOrNull(); + if (ca && cb) + return clasp_make_complex(ca->real() * cb->real() - ca->imaginary() * cb->imaginary(), + ca->real() * cb->imaginary() + ca->imaginary() * cb->real()); + if (ca) + return clasp_make_complex(ca->real() * nb.as_unsafe(), ca->imaginary() * nb.as_unsafe()); + if (cb) + return clasp_make_complex(na.as_unsafe() * cb->real(), na.as_unsafe() * cb->imaginary()); + #ifdef CLASP_LONG_FLOAT - case_Fixnum_v_LongFloat: - case_Bignum_v_LongFloat: - case_Ratio_v_LongFloat: - case_SingleFloat_v_LongFloat: - case_DoubleFloat_v_LongFloat: - case_LongFloat_v_Fixnum: - case_LongFloat_v_Ratio: - case_LongFloat_v_SingleFloat: - case_LongFloat_v_DoubleFloat: - case_LongFloat_v_LongFloat: - return LongFloat_O::create(na->as_long_float() * nb->as_long_float()); -#endif - case_Complex_v_LongFloat: - case_Complex_v_Fixnum: - case_Complex_v_Bignum: - case_Complex_v_Ratio: - case_Complex_v_SingleFloat: - case_Complex_v_DoubleFloat : { - Number_sp aux = na; - na = nb; - nb = aux; - goto Complex_v_Y; - } - case_Fixnum_v_Complex: - case_Bignum_v_Complex: - case_Ratio_v_Complex: - case_SingleFloat_v_Complex: - case_DoubleFloat_v_Complex: - case_LongFloat_v_Complex: - Complex_v_Y: - return clasp_make_complex(gc::As(contagion_mul(na, gc::As(nb)->real())), - gc::As(contagion_mul(na, gc::As(nb)->imaginary()))); - case_Complex_v_Complex : { - Complex_sp ca = gc::As(na); - Complex_sp cb = gc::As(nb); - Real_sp x = ca->real(); - Real_sp y = ca->imaginary(); - Real_sp u = cb->real(); - Real_sp v = cb->imaginary(); - // (x + yi)(u + vi) = (xu - yv) + (xv + yu)i. - return clasp_make_complex(gc::As(contagion_sub(contagion_mul(x, u), contagion_mul(y, v))), - gc::As(contagion_add(contagion_mul(x, v), contagion_mul(y, u)))); - } break; - default: - not_comparable_error(na, nb); - }; - MATH_DISPATCH_END(); -} - -// Forward declaration for contagion_div -Number_sp contagion_div(Number_sp na, Number_sp nb); - -Number_sp complex_divide(Real_sp ar, Real_sp ai, Real_sp br, Real_sp bi) { - // Compute (ar+ai*i)/(br+bi*i). - // Just multiply the numerator and denominator by (br - bi*i) - // to end up with ar*br+ai*bi/z real and ai*br-ar*bi imaginary, - // where z is br^2+bi*2. -#define realmul(A, B) gc::As_unsafe(contagion_mul((A), (B))) -#define realadd(A, B) gc::As_unsafe(contagion_add((A), (B))) -#define realsub(A, B) gc::As_unsafe(contagion_sub((A), (B))) -#define realdiv(A, B) gc::As_unsafe(contagion_div((A), (B))) - Real_sp absB2 = realadd(realmul(br, br), realmul(bi, bi)); - Real_sp rnum = realadd(realmul(ar, br), realmul(ai, bi)); - Real_sp inum = realsub(realmul(ai, br), realmul(ar, bi)); - Real_sp realpart = realdiv(rnum, absB2); - // note: could save a bit of time by checking if inum is zero, - // and if so not bothering to compute imagpart - Real_sp imagpart = realdiv(inum, absB2); - return clasp_make_complex(realpart, imagpart); -#undef realmul -#undef realadd -#undef realsub -#undef realdiv + if (na.isA() || nb.isA()) + return LongFloat_O::create(as_long_float(na) * as_long_float(nb)); +#endif + + if (na.isA() || nb.isA()) + return DoubleFloat_O::create(as_double_float(na) * as_double_float(nb)); + + if (na.single_floatp() || nb.single_floatp()) + return SingleFloat_dummy_O::create(as_single_float(na) * as_single_float(nb)); + +#ifdef CLASP_SHORT_FLOAT + if (na.short_floatp() || nb.short_floatp()) + return ShortFloat_O::create(as_short_float(na) * as_short_float(nb)); +#endif + + Ratio_sp ra = na.asOrNull(), rb = nb.asOrNull(); + if (ra && rb) + return Rational_O::create(ra->numerator() * rb->numerator(), ra->denominator() * rb->denominator()); + if (ra) + return Rational_O::create(ra->numerator() * nb.as_unsafe(), ra->denominator()); + if (rb) + return Rational_O::create(na.as_unsafe() * rb->numerator(), rb->denominator()); + + Bignum_sp ba = na.asOrNull(), bb = nb.asOrNull(); + if (ba && bb) + return mul_bb(ba, bb); + if (ba) + return mul_bx(ba, nb.unsafe_fixnum()); + if (bb) + return mul_bx(bb, na.unsafe_fixnum()); + + // We want to detect when Fixnum * Fixnum multiplication will overflow and only then use bignum arithmetic. + // But C++ doesn't give us a way to do that - so we use the __builtin_mul_overflow clang builtin. + // It will return false if there is no overflow and the multiplication result will be in fr. + // The return value fr may over + // If it doesn't overflow - then this will be faster than always using bignum arithmetic. + Fixnum fa = na.unsafe_fixnum(), fb = nb.unsafe_fixnum(), fr; + bool overflow = __builtin_mul_overflow(fa, fb, &fr); + if (!overflow) + return Integer_O::create(fr); + return core__mul_fixnums(fa, fb); } CL_NAME("TWO-ARG-/"); CL_UNWIND_COOP(true); DOCGROUP(clasp); -CL_DEFUN Number_sp contagion_div(Number_sp na, Number_sp nb) { - MATH_DISPATCH_BEGIN(na, nb) { - case_Fixnum_v_Fixnum: - case_Bignum_v_Fixnum: - case_Fixnum_v_Bignum: - case_Bignum_v_Bignum: - return Rational_O::create(gc::As_unsafe(na), gc::As_unsafe(nb)); - case_Fixnum_v_Ratio: - case_Bignum_v_Ratio: - return Rational_O::create(gc::As(contagion_mul(na, gc::As(nb)->denominator())), - gc::As(nb)->numerator()); - case_Fixnum_v_SingleFloat: - return clasp_make_single_float(clasp_to_float(na) / clasp_to_float(nb)); - case_Fixnum_v_DoubleFloat: - return DoubleFloat_O::create(clasp_to_double(na) / clasp_to_double(nb)); - case_Bignum_v_SingleFloat: - case_Ratio_v_SingleFloat: - return clasp_make_single_float(clasp_to_float(na) / clasp_to_float(nb)); - case_Bignum_v_DoubleFloat: - case_Ratio_v_DoubleFloat: - return DoubleFloat_O::create(clasp_to_double(na) / clasp_to_double(nb)); - case_Ratio_v_Fixnum: - case_Ratio_v_Bignum : { - Integer_sp z = gc::As(contagion_mul(gc::As(na)->denominator(), nb)); - return Rational_O::create(gc::As(na)->numerator(), z); - } - case_Ratio_v_Ratio : { - Ratio_sp ra = gc::As(na); - Ratio_sp rb = gc::As(nb); - Integer_sp num = gc::As(contagion_mul(ra->numerator(), rb->denominator())); - Integer_sp denom = gc::As(contagion_mul(ra->denominator(), rb->numerator())); - return Rational_O::create(num, denom); - } - case_SingleFloat_v_Fixnum: - case_SingleFloat_v_Ratio: - case_SingleFloat_v_Bignum: - case_SingleFloat_v_SingleFloat: - return clasp_make_single_float(clasp_to_float(na) / clasp_to_float(nb)); - case_SingleFloat_v_DoubleFloat: - case_DoubleFloat_v_Fixnum: - case_DoubleFloat_v_Ratio: - case_DoubleFloat_v_Bignum: - case_DoubleFloat_v_SingleFloat: - case_DoubleFloat_v_DoubleFloat: - return DoubleFloat_O::create(clasp_to_double(na) / clasp_to_double(nb)); +CL_DEFUN Number_sp Number_O::div_nn(Number_sp na, Number_sp nb) { + Complex_sp ca = na.asOrNull(), cb = nb.asOrNull(); + if (ca && cb) { + Real_sp den = cb->real() * cb->real() + cb->imaginary() * cb->imaginary(); + return clasp_make_complex((ca->real() * cb->real() + ca->imaginary() * cb->imaginary()) / den, + (ca->imaginary() * cb->real() - ca->real() * cb->imaginary()) / den); + } + if (ca) + return clasp_make_complex(ca->real() / nb.as_unsafe(), ca->imaginary() / nb.as_unsafe()); + if (cb) { + Real_sp den = cb->real() * cb->real() + cb->imaginary() * cb->imaginary(); + return clasp_make_complex((na.as_unsafe() * cb->real()) / den, -(na.as_unsafe() * cb->imaginary()) / den); + } + #ifdef CLASP_LONG_FLOAT - case_Fixnum_v_LongFloat: - case_Ratio_v_LongFloat: - case_SingleFloat_v_LongFloat: - case_DoubleFloat_v_LongFloat: - case_LongFloat_v_Fixnum: - case_LongFloat_v_Ratio: - case_LongFloat_v_SingleFloat: - case_LongFloat_v_DoubleFloat: - case_LongFloat_v_LongFloat: - return LongFloat_O::create(na->as_long_float() / nb->as_long_float()); -#endif - case_Complex_v_Fixnum: - case_Complex_v_Bignum: - case_Complex_v_Ratio: - case_Complex_v_SingleFloat: - case_Complex_v_DoubleFloat: - case_Complex_v_LongFloat : { - Complex_sp ca = gc::As(na); - return clasp_make_complex(gc::As(contagion_div(ca->real(), nb)), gc::As(contagion_div(ca->imaginary(), nb))); - } - case_Fixnum_v_Complex: - case_Bignum_v_Complex: - case_Ratio_v_Complex: - case_SingleFloat_v_Complex: - case_DoubleFloat_v_Complex: - case_LongFloat_v_Complex : { - Complex_sp cb = gc::As_unsafe(nb); - return complex_divide(gc::As_unsafe(na), clasp_make_fixnum(0), cb->real(), cb->imaginary()); - } - case_Complex_v_Complex : { - Complex_sp ca = gc::As(na); - Complex_sp cb = gc::As(nb); - return complex_divide(ca->real(), ca->imaginary(), cb->real(), cb->imaginary()); - } - } - MATH_DISPATCH_END(); - not_comparable_error(na, nb); + if (na.isA() || nb.isA()) + return LongFloat_O::create(as_long_float(na) / as_long_float(nb)); +#endif + + if (na.isA() || nb.isA()) + return DoubleFloat_O::create(as_double_float(na) / as_double_float(nb)); + + if (na.single_floatp() || nb.single_floatp()) + return SingleFloat_dummy_O::create(as_single_float(na) / as_single_float(nb)); + +#ifdef CLASP_SHORT_FLOAT + if (na.short_floatp() || nb.short_floatp()) + return ShortFloat_O::create(as_short_float(na) / as_short_float(nb)); +#endif + + Ratio_sp ra = na.asOrNull(), rb = nb.asOrNull(); + if (ra && rb) + return Rational_O::create(ra->numerator() * rb->denominator(), ra->denominator() * rb->numerator()); + if (ra) + return Rational_O::create(ra->numerator(), ra->denominator() * nb.as_unsafe()); + if (rb) + return Rational_O::create(na.as_unsafe() * rb->denominator(), rb->numerator()); + + return Rational_O::create(na.as_unsafe(), nb.as_unsafe()); } CL_LAMBDA(&rest numbers); @@ -639,7 +407,7 @@ CL_DEFUN Number_sp cl___PLUS_(List_sp numbers) { return make_fixnum(0); Number_sp result = gc::As(oCar(numbers)); for (auto cur : (List_sp)oCdr(numbers)) { - result = contagion_add(result, gc::As(oCar(cur))); + result += gc::As(oCar(cur)); } return result; } @@ -654,7 +422,7 @@ CL_DEFUN Number_sp cl___TIMES_(List_sp numbers) { return make_fixnum(1); Number_sp result = gc::As(oCar(numbers)); for (auto cur : (List_sp)oCdr(numbers)) { - result = contagion_mul(result, gc::As(oCar(cur))); + result *= gc::As(oCar(cur)); } return result; } @@ -670,7 +438,7 @@ CL_DEFUN Number_sp cl___MINUS_(Number_sp num, List_sp numbers) { } Number_sp result = num; for (auto cur : (List_sp)(numbers)) { - result = contagion_sub(result, gc::As(oCar(cur))); + result -= gc::As(oCar(cur)); } return result; } @@ -684,7 +452,7 @@ CL_DEFUN Number_sp cl___DIVIDE_(Number_sp num, List_sp numbers) { } Number_sp result = num; for (auto cur : (List_sp)(numbers)) { - result = contagion_div(result, gc::As(oCar(cur))); + result /= gc::As(oCar(cur)); } return result; } @@ -711,339 +479,258 @@ CL_DEFUN Number_sp cl___DIVIDE_(Number_sp num, List_sp numbers) { See file '../Copyright' for full details. */ -/* - * In Common Lisp, comparisons between floats and integers are performed - * via an intermediate rationalization of the floating point number. In C, - * on the other hand, the comparison is performed by converting the integer - * into a floating point number. However, if the double type is too small - * this may lead to a loss of precision and two numbers being told equal - * when, by Common Lisp standards, would not. - */ -static int double_fix_compare(Fixnum n, double d) { - if ((double)n < d) { +/* ---------------------------------------------------------------------- + + Number_O::compare + +*/ + +template int compare_bignum_float(Bignum_sp x, Float y) { + constexpr size_t limb_width = 8 * sizeof(mp_limb_t); + auto q = float_convert::float_to_quadruple(y); + + if (q.category != float_convert::category::finite) + return q.sign; + + bool negative = Real_O::minusp(x); + + if (negative && (q.significand == 0 || q.sign > 0)) return -1; - } else if ((double)n > d) { - return +1; - } else if (sizeof(double) > sizeof(Fixnum)) { - return 0; - } else { - /* When we reach here, the double type has no - * significant decimal part. However, as explained - * above, the double type is too small and integers - * may coerce to the same double number giving a false - * positive. Hence we perform the comparison in - * integer space. */ - Fixnum m = d; - if (n == m) { - return 0; - } else if (n > m) { - return +1; - } else { - return -1; + + if (!negative && (q.significand == 0 || q.sign < 0)) + return 1; + + int64_t xlen = clasp_integer_length(x); + int64_t ylen = std::bit_width(q.significand) + q.exponent; + + if (xlen < ylen) + return -q.sign; + + if (xlen > ylen) + return q.sign; + + const mp_limb_t* limbs = x->limbs(); + + size_t width = std::bit_width(q.significand); + typename float_convert::uint_t xsig = 0; + bool first = true; + + for (mp_size_t i = std::abs(x->length()) - 1; i > -1; i--) { + mp_limb_t z = limbs[i]; + + if (width > 0) { + auto w = first ? std::bit_width(z) : limb_width; + auto shift = std::min(w, width); + xsig = (xsig << shift) | (z >> (w - shift)); + z &= (mp_limb_t{1} << (w - shift)) - mp_limb_t{1}; + width -= shift; + first = false; + + // if (width == 0) + // fmt::print("{} {}\n", xsig, q.significand); + + if (width == 0 && xsig < q.significand) + return -q.sign; + if (width == 0 && xsig > q.significand) + return q.sign; } + + if (width == 0 && z != 0) + return q.sign; } + + return 0; } -#ifdef CLASP_LONG_FLOAT -static int long_double_fix_compare(Fixnum n, LongFloat d) { - if ((LongFloat)n < d) { +template inline int compare_pod(T x, T y) { + if (x < y) return -1; - } else if ((LongFloat)n > d) { - return +1; - } else if (sizeof(LongFloat) > sizeof(Fixnum)) { - return 0; - } else { - Fixnum m = d; - if (n == m) { - return 0; - } else if (n > m) { - return +1; - } else { - return -1; - } - } + if (x > y) + return 1; + return 0; } -#endif -/* ---------------------------------------------------------------------- +template inline int compare_fixnum_float(Fixnum a, Float b) { + // We can't use C's comparison because it promotes ints to floats, + // which is the opposite of how CL is defined. + // If b is out of range, this is easy. Also covers infinities. + // We do this instead of the more obvious most_positive_fixnum + // comparison mpf, being not-a-power-of-two, cannot be exactly + // represented and clang whines about that. + if (b > ((gc::Fixnum)1 << gc::fixnum_bits)) + return -1; + else if (b < -((gc::Fixnum)1 << gc::fixnum_bits)) + return 1; - basic_compare + gctools::Fixnum ib = b; // per C std, truncates (towards zero). + if (a < ib) + return -1; + else if (a > ib) + return 1; + // a == trunc(b), so we have to check on b's frac part. + // examples: 3.2 3, -3.2 -3, -0.2 0, 0.2 0, 0.0 0 + else if (b > ib) + return -1; + else if (b < ib) + return 1; + else + return 0; +} -*/ +template inline int compare_rational_float(Ratio_sp x, Float y) { + if (std::isinf(y)) + return std::signbit(y) ? 1 : -1; + return Number_O::compare(x, float_to_rational(y)); +} /*! Return -1 if a b */ -int basic_compare(Number_sp na, Number_sp nb) { - MATH_DISPATCH_BEGIN(na, nb) { - case_Fixnum_v_Fixnum : { - gctools::Fixnum fa = unbox_fixnum(gc::As(na)); - gctools::Fixnum fb = unbox_fixnum(gc::As(nb)); - if (fa < fb) - return -1; - else if (fa > fb) - return 1; - else - return 0; - } - case_Fixnum_v_Bignum : { - // Bignums are outside the range of fixnums, so this is easy. - // That is, negative bignums are < all fixnums, - // and positive bignums are > all fixnums. - Bignum_sp bb = gc::As_unsafe(nb); - if (bb->minusp_()) - return 1; - else - return -1; - } - case_Fixnum_v_Ratio: - case_Bignum_v_Ratio : { - Ratio_sp rb = gc::As(nb); - Integer_sp trunc = clasp_integer_divide(rb->numerator(), rb->denominator()); - int res = basic_compare(na, trunc); - if (res == 0) - return (clasp_minusp(rb) ? 1 : -1); - else - return res; - } - // We can't use C's comparison because it promotes ints to floats, - // which is the opposite of how CL is defined. - case_Fixnum_v_SingleFloat : { - float b = nb.unsafe_single_float(); - // If b is out of range, this is easy. Also covers infinities. - // We do this instead of the more obvious most_positive_fixnum - // comparison mpf, being not-a-power-of-two, cannot be exactly - // represented and clang whines about that. - if (b > ((gc::Fixnum)1 << gc::fixnum_bits)) - return -1; - else if (b < -((gc::Fixnum)1 << gc::fixnum_bits)) - return 1; - - gctools::Fixnum a = na.unsafe_fixnum(); - gctools::Fixnum ib = b; // per C std, truncates (towards zero). - if (a < ib) - return -1; - else if (a > ib) - return 1; - // a == trunc(b), so we have to check on b's frac part. - // examples: 3.2 3, -3.2 -3, -0.2 0, 0.2 0, 0.0 0 - else if (b > ib) - return -1; - else if (b < ib) - return 1; - else - return 0; - } - // FIXME: Efficiency - case_Bignum_v_SingleFloat: - case_Ratio_v_SingleFloat : { - float s = nb.unsafe_single_float(); - if (std::isinf(s)) { - if (s > 0.0f) - return -1; - else - return 1; - } else - return basic_compare(na, DoubleFloat_O::rational(s)); - } - case_Fixnum_v_DoubleFloat : { - double b = clasp_to_double(nb); - if (b > ((gc::Fixnum)1 << gc::fixnum_bits)) - return -1; - else if (b < -((gc::Fixnum)1 << gc::fixnum_bits)) - return 1; - - gctools::Fixnum a = na.unsafe_fixnum(); - gctools::Fixnum ib = b; - if (a < ib) - return -1; - else if (a > ib) - return 1; - else if (b > ib) - return -1; - else if (b < ib) - return 1; - else - return 0; - } - case_Bignum_v_DoubleFloat: - case_Ratio_v_DoubleFloat : { - DoubleFloat_sp d = gc::As_unsafe(nb); - if (d->isinf_()) { - if (d->plusp_()) - return -1; - else - return 1; - } else - return basic_compare(na, d->rational_()); - } - case_Bignum_v_Fixnum : { - Bignum_sp ba = gc::As_unsafe(na); - if (ba->plusp_()) - return 1; - else - return -1; - } - case_Bignum_v_Bignum: - return core__next_compare(gc::As_unsafe(na), gc::As_unsafe(nb)); - case_Ratio_v_Fixnum: - case_Ratio_v_Bignum : { - Ratio_sp ra = gc::As(na); - Integer_sp trunc = clasp_integer_divide(ra->numerator(), ra->denominator()); - int res = basic_compare(trunc, nb); - if (res == 0) - return (clasp_minusp(ra) ? -1 : 1); - else - return res; - } - case_Ratio_v_Ratio : { +int Number_O::compare(const Real_sp na, const Real_sp nb) { + Ratio_sp ra = na.asOrNull(), rb = nb.asOrNull(); + if (ra && rb) { // First, divide through the ratios and compare those. // That can give us an answer not requiring consing larger numbers. // Failing that, use a/b <=> c/d is equivalent to ad <=> bc. - Ratio_sp ra = gc::As(na); - Ratio_sp rb = gc::As(nb); Integer_sp ta = clasp_integer_divide(ra->numerator(), ra->denominator()); Integer_sp tb = clasp_integer_divide(rb->numerator(), rb->denominator()); - int res = basic_compare(ta, tb); + int res = compare(ta, tb); if (res != 0) return res; else { - Number_sp left = contagion_mul(ra->numerator(), rb->denominator()); - Number_sp right = contagion_mul(rb->numerator(), ra->denominator()); - return basic_compare(left, right); + return compare(ra->numerator() * rb->denominator(), rb->numerator() * ra->denominator()); } } - case_SingleFloat_v_Fixnum : { - float a = na.unsafe_single_float(); - if (a > ((gc::Fixnum)1 << gc::fixnum_bits)) - return 1; - else if (a < -((gc::Fixnum)1 << gc::fixnum_bits)) - return -1; - - gctools::Fixnum b = nb.unsafe_fixnum(); - gctools::Fixnum ia = a; - if (ia < b) - return -1; - else if (ia > b) - return 1; - else if (a > ia) - return 1; - else if (a < ia) - return -1; + if (ra) { +#ifdef CLASP_LONG_FLOAT + if (nb.isA()) + return compare_rational_float(ra, nb.as_unsafe()->get()); +#endif + if (nb.isA()) + return compare_rational_float(ra, nb.as_unsafe()->get()); + if (nb.single_floatp()) + return compare_rational_float(ra, nb.unsafe_single_float()); +#ifdef CLASP_SHORT_FLOAT + if (nb.short_floatp()) + return compare_rational_float(ra, nb.unsafe_short_float()); +#endif + Integer_sp trunc = clasp_integer_divide(ra->numerator(), ra->denominator()); + int res = compare(trunc, nb); + if (res == 0) + return (Real_O::minusp(ra) ? -1 : 1); else - return 0; - } - case_SingleFloat_v_Bignum: - case_SingleFloat_v_Ratio : { - float s = na.unsafe_single_float(); - if (std::isinf(s)) { - if (s > 0.0f) - return 1; - else - return -1; - } else - return basic_compare(DoubleFloat_O::rational(s), nb); - } - case_SingleFloat_v_SingleFloat : { - float a = na.unsafe_single_float(); - float b = nb.unsafe_single_float(); - if (a < b) - return -1; - else if (a > b) - return 1; + return res; + } + if (rb) { +#ifdef CLASP_LONG_FLOAT + if (na.isA()) + return -compare_rational_float(rb, na.as_unsafe()->get()); +#endif + if (na.isA()) + return -compare_rational_float(rb, na.as_unsafe()->get()); + if (na.single_floatp()) + return -compare_rational_float(rb, na.unsafe_single_float()); +#ifdef CLASP_SHORT_FLOAT + if (na.short_floatp()) + return -compare_rational_float(rb, na.unsafe_short_float()); +#endif + Integer_sp trunc = clasp_integer_divide(rb->numerator(), rb->denominator()); + int res = compare(na, trunc); + if (res == 0) + return (Real_O::minusp(rb) ? 1 : -1); else - return 0; + return res; } - case_DoubleFloat_v_Fixnum : { - double a = clasp_to_double(na); - if (a > ((gc::Fixnum)1 << gc::fixnum_bits)) - return 1; - else if (a < -((gc::Fixnum)1 << gc::fixnum_bits)) - return -1; - gctools::Fixnum b = nb.unsafe_fixnum(); - gctools::Fixnum ia = a; - if (ia < b) - return -1; - else if (a > b) - return 1; - else if (a > ia) + Bignum_sp ba = na.asOrNull(), bb = nb.asOrNull(); + if (ba && bb) + return core__next_compare(ba, bb); + if (ba) { +#ifdef CLASP_LONG_FLOAT + if (nb.isA()) + return compare_bignum_float(ba, nb.as_unsafe()->get()); +#endif + if (nb.isA()) + return compare_bignum_float(ba, nb.as_unsafe()->get()); + if (nb.single_floatp()) + return compare_bignum_float(ba, nb.unsafe_single_float()); +#ifdef CLASP_SHORT_FLOAT + if (nb.short_floatp()) + return compare_bignum_float(ba, nb.unsafe_short_float()); +#endif + if (ba->plusp_()) return 1; - else if (a < ia) - return -1; else - return 0; - } - case_DoubleFloat_v_Bignum: - case_DoubleFloat_v_Ratio : { - DoubleFloat_sp d = gc::As_unsafe(na); - if (d->isinf_()) { - if (d->plusp_()) - return 1; - else - return -1; - } else - return basic_compare(d->rational_(), nb); - } - case_SingleFloat_v_DoubleFloat: - case_DoubleFloat_v_SingleFloat: - case_DoubleFloat_v_DoubleFloat : { - double a = clasp_to_double(na); - double b = clasp_to_double(nb); - if (a < b) return -1; - else if (a > b) + } + if (bb) { +#ifdef CLASP_LONG_FLOAT + if (na.isA()) + return -compare_bignum_float(bb, na.as_unsafe()->get()); +#endif + if (na.isA()) + return -compare_bignum_float(bb, na.as_unsafe()->get()); + if (na.single_floatp()) + return -compare_bignum_float(bb, na.unsafe_single_float()); +#ifdef CLASP_SHORT_FLOAT + if (na.short_floatp()) + return -compare_bignum_float(bb, na.unsafe_short_float()); +#endif + if (bb->minusp_()) return 1; else - return 0; + return -1; } + + if (na.fixnump() && nb.fixnump()) + return compare_pod(na.unsafe_fixnum(), nb.unsafe_fixnum()); + if (na.fixnump()) { #ifdef CLASP_LONG_FLOAT - case_Fixnum_v_LongFloat: - return long_double_fix_compare(gc::As(na)->get(), nb.as()->get()); - break; - case_LongFloat_v_Fixnum: - return -long_double_fix_compare(gc::As(nb)->get(), na.as()->get()); - break; - case_Bignum_v_LongFloat: - case_Ratio_v_LongFloat: - case_SingleFloat_v_LongFloat: - case_DoubleFloat_v_LongFloat: - case_LongFloat_v_Ratio: - case_LongFloat_v_SingleFloat: - case_LongFloat_v_DoubleFloat: - case_LongFloat_v_LongFloat : { - LongFloat a = na->as_long_float(); - LongFloat b = nb->as_long_float(); - if (a < b) - return -1; - if (a == b) - return 0; - return 1; + if (nb.isA()) + return compare_fixnum_float(na.unsafe_fixnum(), nb.as_unsafe()->get()); +#endif + if (nb.isA()) + return compare_fixnum_float(na.unsafe_fixnum(), nb.as_unsafe()->get()); + if (nb.single_floatp()) + return compare_fixnum_float(na.unsafe_fixnum(), nb.unsafe_single_float()); +#ifdef CLASP_SHORT_FLOAT + if (nb.short_floatp()) + return compare_fixnum_float(na.unsafe_fixnum(), nb.unsafe_short_float()); +#endif + not_comparable_error(na, nb); } + if (nb.fixnump()) { +#ifdef CLASP_LONG_FLOAT + if (na.isA()) + return -compare_fixnum_float(nb.unsafe_fixnum(), na.as_unsafe()->get()); +#endif + if (na.isA()) + return -compare_fixnum_float(nb.unsafe_fixnum(), na.as_unsafe()->get()); + if (na.single_floatp()) + return -compare_fixnum_float(nb.unsafe_fixnum(), na.unsafe_single_float()); +#ifdef CLASP_SHORT_FLOAT + if (na.short_floatp()) + return -compare_fixnum_float(nb.unsafe_fixnum(), na.unsafe_short_float()); #endif - default: not_comparable_error(na, nb); - }; - MATH_DISPATCH_END(); -} - -/// this is used for comparison of reals, not for complex, so use Real_sp -T_sp numbers_monotonic(int s, int t, List_sp args) { - Real_sp c = gc::As(oCar(args)); - Real_sp d; - int dir; - args = oCdr(args); - while (args.notnilp()) { - d = gc::As(oCar(args)); - dir = s * basic_compare(c, d); - if (dir < t) - return _lisp->_false(); - c = d; - args = oCdr(args); } - return _lisp->_true(); -}; + +#ifdef CLASP_LONG_FLOAT + if (na.isA() || nb.isA()) + return compare_pod(Number_O::as_long_float(na), Number_O::as_long_float(nb)); +#endif + if (na.isA() || nb.isA()) + return compare_pod(Number_O::as_double_float(na), Number_O::as_double_float(nb)); + if (na.single_floatp() || nb.single_floatp()) + return compare_pod(Number_O::as_single_float(na), Number_O::as_single_float(nb)); +#ifdef CLASP_SHORT_FLOAT + if (na.short_floatp() || nb.short_floatp()) + return compare_pod(Number_O::as_short_float(na), Number_O::as_short_float(nb)); +#endif + + not_comparable_error(na, nb); +} T_sp numbers_monotonic_vaslist(int s, int t, Vaslist_sp args) { Real_sp c = gc::As(args->next_arg()); @@ -1051,7 +738,7 @@ T_sp numbers_monotonic_vaslist(int s, int t, Vaslist_sp args) { int dir; while (args->nargs() > 0) { d = gc::As(args->next_arg()); - dir = s * basic_compare(c, d); + dir = s * Number_O::compare(c, d); if (dir < t) return _lisp->_false(); c = d; @@ -1062,22 +749,22 @@ T_sp numbers_monotonic_vaslist(int s, int t, Vaslist_sp args) { CL_NAME("TWO-ARG-<"); CL_UNWIND_COOP(true); DOCGROUP(clasp); -CL_DEFUN bool two_arg__LT_(Number_sp x, Number_sp y) { return basic_compare(x, y) == -1; } +CL_DEFUN bool two_arg__LT_(Real_sp x, Real_sp y) { return Number_O::compare(x, y) == -1; } CL_NAME("TWO-ARG-<="); CL_UNWIND_COOP(true); DOCGROUP(clasp); -CL_DEFUN bool two_arg__LE_(Number_sp x, Number_sp y) { return basic_compare(x, y) != 1; } +CL_DEFUN bool two_arg__LE_(Real_sp x, Real_sp y) { return Number_O::compare(x, y) != 1; } CL_NAME("TWO-ARG->"); CL_UNWIND_COOP(true); DOCGROUP(clasp); -CL_DEFUN bool two_arg__GT_(Number_sp x, Number_sp y) { return basic_compare(x, y) == 1; } +CL_DEFUN bool two_arg__GT_(Real_sp x, Real_sp y) { return Number_O::compare(x, y) == 1; } CL_NAME("TWO-ARG->="); CL_UNWIND_COOP(true); DOCGROUP(clasp); -CL_DEFUN bool two_arg__GE_(Number_sp x, Number_sp y) { return basic_compare(x, y) != -1; } +CL_DEFUN bool two_arg__GE_(Real_sp x, Real_sp y) { return Number_O::compare(x, y) != -1; } CL_LAMBDA(core:&va-rest args); CL_UNWIND_COOP(true); @@ -1119,119 +806,133 @@ CL_DEFUN T_sp cl___GE_(Vaslist_sp args) { return numbers_monotonic_vaslist(1, 0, args); }; +bool basic_equalp(Number_sp na, Number_sp nb); + +template bool equalp_ratio_float(Ratio_sp x, Float y) { + auto q = float_convert::float_to_quadruple(y); + + if (q.category != float_convert::category::finite || q.significand == 0 || q.exponent >= 0 || + (q.sign > 0 && Real_O::minusp(x)) || (q.sign < 0 && Real_O::plusp(x))) + return false; + + return basic_equalp(x, float_to_rational(y)); +} + /*! Return true if two numbers are equal otherwise false */ bool basic_equalp(Number_sp na, Number_sp nb) { - MATH_DISPATCH_BEGIN(na, nb) { - case_Fixnum_v_Fixnum : { - gctools::Fixnum fa = unbox_fixnum(gc::As(na)); - gctools::Fixnum fb = unbox_fixnum(gc::As(nb)); - return fa == fb; - } - case_Fixnum_v_Bignum: - case_Bignum_v_Fixnum: - // bignums are never in fixnum range. + Complex_sp ca = na.asOrNull(), cb = nb.asOrNull(); + if (ca && cb) + return basic_equalp(ca->real(), cb->real()) && basic_equalp(ca->imaginary(), cb->imaginary()); + if (ca) + return Number_O::zerop(ca->imaginary()) && basic_equalp(ca->real(), nb); + if (cb) + return Number_O::zerop(cb->imaginary()) && basic_equalp(cb->real(), na); + + Ratio_sp ra = na.asOrNull(), rb = nb.asOrNull(); + if (ra && rb) + return basic_equalp(ra->numerator(), rb->numerator()) && basic_equalp(ra->denominator(), rb->denominator()); + if (ra) { +#ifdef CLASP_LONG_FLOAT + if (nb.isA()) + return equalp_ratio_float(ra, nb.as_unsafe()->get()); +#endif + if (nb.isA()) + return equalp_ratio_float(ra, nb.as_unsafe()->get()); + if (nb.single_floatp()) + return equalp_ratio_float(ra, nb.unsafe_single_float()); +#ifdef CLASP_SHORT_FLOAT + if (nb.short_floatp()) + return equalp_ratio_float(ra, nb.unsafe_short_float()); +#endif + // Normalized ratios are never integers. return false; - case_Fixnum_v_Ratio: - case_Ratio_v_Fixnum: - case_Bignum_v_Ratio: - case_Ratio_v_Bignum: + } + if (rb) { +#ifdef CLASP_LONG_FLOAT + if (na.isA()) + return equalp_ratio_float(rb, na.as_unsafe()->get()); +#endif + if (na.isA()) + return equalp_ratio_float(rb, na.as_unsafe()->get()); + if (na.single_floatp()) + return equalp_ratio_float(rb, na.unsafe_single_float()); +#ifdef CLASP_SHORT_FLOAT + if (na.short_floatp()) + return equalp_ratio_float(rb, na.unsafe_short_float()); +#endif // Normalized ratios are never integers. return false; - case_Fixnum_v_SingleFloat: - case_Bignum_v_SingleFloat: - case_Ratio_v_SingleFloat : { - float s = nb.unsafe_single_float(); - if (std::isinf(s)) - return false; - else - return basic_equalp(na, DoubleFloat_O::rational(s)); } - case_Fixnum_v_DoubleFloat: - case_Bignum_v_DoubleFloat: - case_Ratio_v_DoubleFloat : { - DoubleFloat_sp d = gc::As_unsafe(nb); - if (d->isinf_()) - return false; - else - return basic_equalp(na, d->rational_()); - } - case_Bignum_v_Bignum : { return (core__next_compare(gc::As_unsafe(na), gc::As_unsafe(nb)) == 0); } - case_Ratio_v_Ratio : { - // ratios are normalized - Ratio_sp ra = gc::As(na); - Ratio_sp rb = gc::As(nb); - return (basic_equalp(ra->numerator(), rb->numerator()) && basic_equalp(ra->denominator(), rb->denominator())); - } - case_SingleFloat_v_Fixnum: - case_SingleFloat_v_Bignum: - case_SingleFloat_v_Ratio : { - float s = na.unsafe_single_float(); - if (std::isinf(s)) - return false; - else - return basic_equalp(DoubleFloat_O::rational(s), nb); - } - case_SingleFloat_v_SingleFloat : { - float a = clasp_to_float(na); - float b = clasp_to_float(nb); - return a == b; - } - case_DoubleFloat_v_Fixnum: - case_DoubleFloat_v_Bignum: - case_DoubleFloat_v_Ratio : { - DoubleFloat_sp d = gc::As_unsafe(na); - if (d->isinf_()) - return false; - else - return basic_equalp(d->rational_(), nb); - } - case_SingleFloat_v_DoubleFloat: - case_DoubleFloat_v_SingleFloat: - case_DoubleFloat_v_DoubleFloat : { - double a = clasp_to_double(na); - double b = clasp_to_double(nb); - return a == b; - } - case_Fixnum_v_LongFloat: - case_Bignum_v_LongFloat: - case_Ratio_v_LongFloat: - case_SingleFloat_v_LongFloat: - case_DoubleFloat_v_LongFloat: - case_LongFloat_v_Fixnum: - case_LongFloat_v_Ratio: - case_LongFloat_v_SingleFloat: - case_LongFloat_v_DoubleFloat: - case_LongFloat_v_LongFloat : { - LongFloat a = clasp_to_long_float(na); - LongFloat b = clasp_to_long_float(nb); - return a == b; - } - case_Complex_v_LongFloat: - case_Complex_v_Fixnum: - case_Complex_v_Bignum: - case_Complex_v_Ratio: - case_Complex_v_SingleFloat: - case_Complex_v_DoubleFloat : { - Number_sp aux = na; - na = nb; - nb = aux; - goto Complex_v_Y; - } - case_Fixnum_v_Complex: - case_Bignum_v_Complex: - case_Ratio_v_Complex: - case_SingleFloat_v_Complex: - case_DoubleFloat_v_Complex: - case_LongFloat_v_Complex: - Complex_v_Y: - return (clasp_zerop(gc::As(nb)->imaginary()) && basic_equalp(na, gc::As(nb)->real())); - case_Complex_v_Complex: - return (basic_equalp(gc::As(na)->real(), gc::As(nb)->real()) && - basic_equalp(gc::As(na)->imaginary(), gc::As(nb)->imaginary())); - default: - not_comparable_error(na, nb); - }; - MATH_DISPATCH_END(); + + Bignum_sp ba = na.asOrNull(), bb = nb.asOrNull(); + if (ba && bb) + return core__next_compare(ba, bb) == 0; + if (ba) { +#ifdef CLASP_LONG_FLOAT + if (nb.isA()) + return compare_bignum_float(ba, nb.as_unsafe()->get()) == 0; +#endif + if (nb.isA()) + return compare_bignum_float(ba, nb.as_unsafe()->get()) == 0; + if (nb.single_floatp()) + return compare_bignum_float(ba, nb.unsafe_single_float()) == 0; +#ifdef CLASP_SHORT_FLOAT + if (nb.short_floatp()) + return compare_bignum_float(ba, nb.unsafe_short_float()) == 0; +#endif + // bignums are never in fixnum range. + return false; + } + if (bb) { +#ifdef CLASP_LONG_FLOAT + if (na.isA()) + return compare_bignum_float(bb, na.as_unsafe()->get()) == 0; +#endif + if (na.isA()) + return compare_bignum_float(bb, na.as_unsafe()->get()) == 0; + if (na.single_floatp()) + return compare_bignum_float(bb, na.unsafe_single_float()) == 0; +#ifdef CLASP_SHORT_FLOAT + if (na.short_floatp()) + return compare_bignum_float(bb, na.unsafe_short_float()) == 0; +#endif + // bignums are never in fixnum range. + return false; + } + +#ifdef CLASP_LONG_FLOAT + if (na.isA()) + return nb.fixnump() ? compare_fixnum_float(nb.unsafe_fixnum(), na.as_unsafe()->get()) == 0 + : na.as_unsafe()->get() == Number_O::as_long_float(nb); + if (nb.isA()) + return na.fixnump() ? compare_fixnum_float(na.unsafe_fixnum(), nb.as_unsafe()->get()) == 0 + : nb.as_unsafe()->get() == Number_O::as_long_float(na); +#endif + + if (na.isA()) + return nb.fixnump() ? compare_fixnum_float(nb.unsafe_fixnum(), na.as_unsafe()->get()) == 0 + : na.as_unsafe()->get() == Number_O::as_double_float(nb); + if (nb.isA()) + return na.fixnump() ? compare_fixnum_float(na.unsafe_fixnum(), nb.as_unsafe()->get()) == 0 + : nb.as_unsafe()->get() == Number_O::as_double_float(na); + + if (na.single_floatp()) + return nb.fixnump() ? compare_fixnum_float(nb.unsafe_fixnum(), na.unsafe_single_float()) == 0 + : na.unsafe_single_float() == Number_O::as_single_float(nb); + if (nb.single_floatp()) + return na.fixnump() ? compare_fixnum_float(na.unsafe_fixnum(), nb.unsafe_single_float()) == 0 + : nb.unsafe_single_float() == Number_O::as_single_float(na); + +#ifdef CLASP_SHORT_FLOAT + if (na.short_floatp()) + return nb.fixnump() ? compare_fixnum_float(nb.unsafe_fixnum(), na.unsafe_short_float()) == 0 + : na.unsafe_short_float() == Number_O::as_short_float(nb); + if (nb.short_floatp()) + return na.fixnump() ? compare_fixnum_float(na.unsafe_fixnum(), nb.unsafe_short_float()) == 0 + : nb.unsafe_short_float() == Number_O::as_short_float(na); +#endif + + return na.unsafe_fixnum() == nb.unsafe_fixnum(); } CL_NAME("TWO-ARG-="); @@ -1334,8 +1035,6 @@ SYMBOL_EXPORT_SC_(CorePkg, logxor_2op); SYMBOL_EXPORT_SC_(CorePkg, logior_2op); SYMBOL_EXPORT_SC_(CorePkg, logeqv_2op); -Number_sp Number_O::create(double val) { return DoubleFloat_O::create(val); } - bool Number_O::equal(T_sp obj) const { if (this->eq(obj)) return true; @@ -1467,18 +1166,17 @@ Integer_sp Integer_O::create(unsigned long v) { } #endif -Integer_sp Integer_O::create(std::floating_point auto v) { +/*Integer_sp Integer_O::create(std::floating_point auto v) { // Why >= and = static_cast(gc::most_negative_fixnum) && - v < static_cast(gc::most_positive_fixnum)) + if (v >= static_cast(gc::most_negative_fixnum) && v < static_cast(gc::most_positive_fixnum)) return clasp_make_fixnum(v); else return Bignum_O::create(v); -} +}*/ template Integer_sp Integer_O::create(float v); template Integer_sp Integer_O::create(double v); @@ -1506,60 +1204,17 @@ SYMBOL_EXPORT_SC_(ClPkg, logxor); namespace core { -// ------------------------------------------------------------------------ - -Number_sp ShortFloat_O::reciprocal_() const { return ShortFloat_O::create(1.0 / this->_Value); } - -Number_sp ShortFloat_O::signum_() const { return ShortFloat_O::create(this->_Value > 0.0 ? 1 : (this->_Value < 0.0 ? -1 : 0)); } - -float ShortFloat_O::as_float_() const { return (float)this->_Value; } - -double ShortFloat_O::as_double_() const { return (double)this->_Value; } - -LongFloat ShortFloat_O::as_long_float_() const { return (LongFloat)this->_Value; } - -CL_LISPIFY_NAME("core:castToInteger"); -CL_DEFMETHOD Integer_sp ShortFloat_O::castToInteger() const { - if (this->_Value < 0) { - float f = -this->_Value; - int cf = *(int*)&f; - return gc::As(clasp_negate(Integer_O::create((gc::Fixnum)cf))); - } - int cf = *(int*)&this->_Value; - return Integer_O::create((gc::Fixnum)cf); -} - -Number_sp ShortFloat_O::abs_() const { return ShortFloat_O::create(fabs(this->_Value)); } - -void ShortFloat_O::sxhash_(HashGenerator& hg) const { - hg.addValue((std::fpclassify(this->_Value) == FP_ZERO) ? 0u : float_convert::to_bits(this->_Value)); -} - -bool ShortFloat_O::eql_(T_sp obj) const { - if (this->eq(obj)) - return true; - if (gc::IsA(obj)) { - Number_sp num = gc::As(obj); - return this->get() == clasp_to_double(num); - } - return false; -} - -string ShortFloat_O::__repr__() const { - stringstream ss; - ss << this->_Value; - return ss.str(); -} - //-------------------------------------------------- Number_sp DoubleFloat_O::reciprocal_() const { return DoubleFloat_O::create(1.0 / this->_Value); } -float DoubleFloat_O::as_float_() const { return (float)this->_Value; } +short_float_t DoubleFloat_O::as_short_float_() const { return (short_float_t)this->_Value; } + +single_float_t DoubleFloat_O::as_single_float_() const { return (float)this->_Value; } -double DoubleFloat_O::as_double_() const { return (double)this->_Value; } +double_float_t DoubleFloat_O::as_double_float_() const { return (double)this->_Value; } -LongFloat DoubleFloat_O::as_long_float_() const { return (LongFloat)this->_Value; } +long_float_t DoubleFloat_O::as_long_float_() const { return (long_float_t)this->_Value; } CL_LISPIFY_NAME("core:castToInteger"); CL_DEFMETHOD Integer_sp DoubleFloat_O::castToInteger() const { @@ -1573,21 +1228,17 @@ CL_DEFMETHOD Integer_sp DoubleFloat_O::castToInteger() const { return Integer_O::create((gctools::Fixnum)cf); } -Number_sp DoubleFloat_O::signum_() const { return DoubleFloat_O::create(this->_Value > 0.0 ? 1 : (this->_Value < 0.0 ? -1 : 0)); } +Number_sp DoubleFloat_O::signum_() const { return create(_signum(_Value)); } void DoubleFloat_O::sxhash_(HashGenerator& hg) const { - hg.addValue((std::fpclassify(this->_Value) == FP_ZERO) ? 0u : float_convert::to_bits(this->_Value)); + hg.addValue((std::fpclassify(this->_Value) == FP_ZERO) ? 0u : float_convert::float_to_bits(this->_Value)); } bool DoubleFloat_O::eql_(T_sp obj) const { if (this->eq(obj)) return true; - if (DoubleFloat_sp other = obj.asOrNull()) { - ASSERT(sizeof(this->_Value) == sizeof(int64_t)); - int64_t me = *(int64_t*)(&this->_Value); - int64_t them = *(int64_t*)(&other->_Value); - return me == them; - } + if (DoubleFloat_sp other = obj.asOrNull()) + return _Value == other->get() && std::signbit(_Value) == std::signbit(other->get()); return false; } @@ -1602,11 +1253,13 @@ string DoubleFloat_O::__repr__() const { // LongFloat stuff #ifdef CLASP_LONG_FLOAT -float LongFloat_O::as_float() const { return (float)this->_Value; } +short_float_t LongFloat_O::as_short_float_() const { return (short_float_t)this->_Value; } -double LongFloat_O::as_double() const { return (double)this->_Value; } +single_float_t LongFloat_O::as_single_float_() const { return (float)this->_Value; } -LongFloat LongFloat_O::as_long_float() const { return (LongFloat)this->_Value; } +double_float_t LongFloat_O::as_double_float_() const { return (double)this->_Value; } + +long_float_t LongFloat_O::as_long_float_() const { return (long_float_t)this->_Value; } CL_LISPIFY_NAME("core:castToInteger"); CL_DEFMETHOD Integer_sp LongFloat_O::castToInteger() const { @@ -1615,52 +1268,28 @@ CL_DEFMETHOD Integer_sp LongFloat_O::castToInteger() const { if (this->_Value < 0) { double f = -this->_Value; long long int cf = *(long long int*)&f; - return Integer_O::create(cf)->negate().as(); + return gc::As(Integer_O::create(cf)->negate()); } long long int cf = *(long long int*)&this->_Value; return Integer_O::create(cf); #endif } -Number_sp LongFloat_O::copy() const { return LongFloat_O::create(this->_Value); } - -Number_sp LongFloat_O::reciprocal_() const { return LongFloat_O::create(1.0 / this->_Value); } +Number_sp LongFloat_O::reciprocal_() const { return LongFloat_O::create(long_float_t{1.0} / this->_Value); } -string LongFloat_O::valueAsString() const { - stringstream ss; - ss << this->_Value; - return ss.str(); +void LongFloat_O::sxhash_(HashGenerator& hg) const { + hg.addValue((std::fpclassify(this->_Value) == FP_ZERO) ? 0u : float_convert::float_to_bits(this->_Value)); } -Number_sp LongFloat_O::abs() const { return LongFloat_O::create(fabs(this->_Value)); } - -void LongFloat_O::sxhash(HashGenerator& hg) const { - hg.addValue((std::fpclassify(this->_Value) == FP_ZERO) ? 0u : float_convert::to_bits(this->_Value)); -} - -bool LongFloat_O::eql(T_sp obj) const { +bool LongFloat_O::eql_(T_sp obj) const { if (this->eq(obj)) return true; - if (gc::IsA(obj)) { - Number_sp num = obj.as(); - return this->get() == num->as_double(); - } + if (LongFloat_sp other = obj.asOrNull()) + return _Value == other->get() && std::signbit(_Value) == std::signbit(other->get()); return false; } -bool LongFloat_O::eqn(T_sp obj) const { - if (core__long_float_p(obj)) { - LongFloat_sp t = obj.as(); - return this->get() == t->get(); - } else if (core__fixnump(obj)) { - Fixnum_sp t = gc::As(obj); - return this->get() == t->get(); - } - ASSERT(!cl__numberp(obj)); - return false; -} - -Number_sp LongFloat_O::signum() const { return LongFloat_O::create(this->_Value > 0.0 ? 1 : (this->_Value < 0.0 ? -1 : 0)); } +Number_sp LongFloat_O::signum_() const { return create(_signum(_Value)); } string LongFloat_O::__repr__() const { stringstream ss; @@ -1681,7 +1310,7 @@ static Integer_sp mantissa_and_exponent_from_ratio(Integer_sp num, Integer_sp de * appropriate exponent. */ bool negative = false; - if (clasp_minusp(num)) { + if (Real_O::minusp(num)) { negative = true; num = gc::As_unsafe(clasp_negate(num)); } @@ -1700,7 +1329,7 @@ static Integer_sp mantissa_and_exponent_from_ratio(Integer_sp num, Integer_sp de quotient = clasp_ash(quotient, -1); } /* round quotient */ - if (clasp_oddp(quotient)) { + if (Integer_O::oddp(quotient)) { quotient = gc::As_unsafe(clasp_one_plus(quotient)); } /* shift out the remaining unnecessary digit of quotient */ @@ -1718,22 +1347,24 @@ template inline Float ratio_to_float(Integer_sp num, Integer_sp .sign = 1 }; - if (clasp_minusp(num)) { + if (Real_O::minusp(num)) { q.sign = -1; num = gc::As_unsafe(clasp_negate(num)); } - q.exponent = clasp_integer_length(num) - clasp_integer_length(den) - float_convert::significand_width - 1; + q.exponent = clasp_integer_length(num) - clasp_integer_length(den) - float_convert::traits::significand_width - 1; q.significand = clasp_to_integral::uint_t>(clasp_integer_divide(clasp_ash(num, -q.exponent), den)); - return float_convert::from_quadruple(q); + return float_convert::quadruple_to_float(q); } -float Ratio_O::as_float_() const { return ratio_to_float(this->_numerator, this->_denominator); } +short_float_t Ratio_O::as_short_float_() const { return ratio_to_float(this->_numerator, this->_denominator); } + +single_float_t Ratio_O::as_single_float_() const { return ratio_to_float(this->_numerator, this->_denominator); } -double Ratio_O::as_double_() const { return ratio_to_float(this->_numerator, this->_denominator); } +double_float_t Ratio_O::as_double_float_() const { return ratio_to_float(this->_numerator, this->_denominator); } -LongFloat Ratio_O::as_long_float_() const { return ratio_to_float(this->_numerator, this->_denominator); } +long_float_t Ratio_O::as_long_float_() const { return ratio_to_float(this->_numerator, this->_denominator); } string Ratio_O::__repr__() const { stringstream ss; @@ -1742,7 +1373,8 @@ string Ratio_O::__repr__() const { } Number_sp Ratio_O::abs_() const { - return Ratio_O::create_primitive(gc::As_unsafe(clasp_abs(gc::As(this->_numerator))), this->_denominator); + return Ratio_O::create_primitive(gc::As_unsafe(Number_O::abs(gc::As(this->_numerator))), + this->_denominator); } bool Ratio_O::eql_(T_sp obj) const { @@ -1765,11 +1397,15 @@ void Ratio_O::sxhash_(HashGenerator& hg) const { } Number_sp Ratio_O::signum_() const { - ASSERT(clasp_plusp(this->_denominator)); - return clasp_signum(this->_numerator); + ASSERT(Real_O::plusp(this->_denominator)); + return signum(this->_numerator); } -Number_sp Ratio_O::sqrt_() const { return float_sqrt(this->as_float_()); } +CL_PKG_NAME(ClPkg, signum); +DOCGROUP(clasp) +CL_DEFUN Number_sp cl__signum(Number_sp num) { return Number_O::signum(num); } + +Number_sp Ratio_O::sqrt_() const { return float_sqrt(this->as_single_float_()); } Number_sp Ratio_O::reciprocal_() const { Integer_sp num = this->_numerator, denom = this->_denominator; @@ -1781,7 +1417,7 @@ Number_sp Ratio_O::reciprocal_() const { return clasp_negate(denom); } } - if (clasp_minusp(num)) { + if (Real_O::minusp(num)) { Integer_sp indenom = gc::As_unsafe(clasp_negate(denom)); Integer_sp innum = gc::As_unsafe(clasp_negate(num)); return Ratio_O::create_primitive(indenom, innum); @@ -1807,7 +1443,7 @@ void Ratio_O::setf_numerator_denominator(Integer_sp inum, Integer_sp idenom) { } return; } - if (clasp_minusp(idenom)) { + if (Real_O::minusp(idenom)) { this->_numerator = gc::As(clasp_negate(num)); this->_denominator = gc::As(clasp_negate(denom)); } else { @@ -1822,7 +1458,7 @@ Number_sp Complex_O::signum_() const { if (this->zerop_()) return this->asSmartPtr(); else - return clasp_divide(this->asSmartPtr(), this->abs_()); + return this->asSmartPtr() / this->abs_(); } string Complex_O::__repr__() const { @@ -1851,17 +1487,14 @@ bool Complex_O::eql_(T_sp o) const { return false; } -Number_sp Complex_O::abs_() const { - return clasp_sqrt(clasp_plus(clasp_times(this->_real, this->_real), clasp_times(this->_imaginary, this->_imaginary))); -} +Number_sp Complex_O::abs_() const { return Number_O::sqrt(this->_real * this->_real + this->_imaginary * this->_imaginary); } Number_sp Complex_O::reciprocal_() const { // 1/(a+bi) = (a-bi)/(a^2+b^2) by basic algebra. // alternately we could just clasp_divide. I dunno if reciprocal_ is terribly necessary. - Real_sp square_modulus = - gc::As_unsafe(clasp_plus(clasp_times(this->_real, this->_real), clasp_times(this->_imaginary, this->_imaginary))); - return Complex_O::create(gc::As_unsafe(clasp_divide(this->_real, square_modulus)), - gc::As_unsafe(clasp_divide(clasp_negate(this->_imaginary), square_modulus))); + Real_sp square_modulus = gc::As_unsafe(this->_real * this->_real + this->_imaginary * this->_imaginary); + return Complex_O::create(gc::As_unsafe(this->_real / square_modulus), + gc::As_unsafe(-this->_imaginary / square_modulus)); } /* ---------------------------------------------------------------------- @@ -1888,22 +1521,18 @@ Number_sp Complex_O::reciprocal_() const { */ Number_sp DoubleFloat_O::sqrt_() const { - if (clasp_minusp(this->asSmartPtr())) { - Number_sp x = clasp_sqrt(clasp_negate(this->asSmartPtr())); - return clasp_make_complex(DoubleFloat_O::create(0.0), gc::As(x)); - } else { - return DoubleFloat_O::create(::sqrt(this->_Value)); - } + if (_Value < 0.0) + return clasp_make_complex(DoubleFloat_O::create(0.0), DoubleFloat_O::create(std::sqrt(-_Value))); + + return DoubleFloat_O::create(std::sqrt(this->_Value)); } #ifdef CLASP_LONG_FLOAT Number_sp LongFloat_O::sqrt_() const { - if (this->minusp()) { - Number_sp x = this->negate()->sqrt(); - return clasp_make_complex(LongFloat_O::create(0.0), x.as()); - } else { - return LongFloat_O::create(sqrtl(this->_Value)); - } + if (_Value < long_float_t{0.0}) + return clasp_make_complex(LongFloat_O::create(long_float_t{0.0}), LongFloat_O::create(std::sqrt(-_Value))); + + return LongFloat_O::create(std::sqrt(_Value)); } #endif @@ -1913,11 +1542,11 @@ Number_sp Bignum_O::sqrt_() const { // hypothetically we could use mpn_sqrtrem instead, but i imagine it's slower. // We convert to a double for maximum range, but return a single as required // by CLHS. - double z = this->as_double_(); + double z = this->as_double_float_(); if (z < 0) - return clasp_make_complex(clasp_make_single_float(0.0), clasp_make_single_float(sqrt(-z))); + return clasp_make_complex(clasp_make_single_float(0.0), clasp_make_single_float(std::sqrt(-z))); else - return clasp_make_single_float(sqrt(z)); + return clasp_make_single_float(std::sqrt(z)); } Number_sp Bignum_O::reciprocal_() const { @@ -1932,7 +1561,14 @@ CL_DECLARE(); CL_UNWIND_COOP(true); CL_DOCSTRING(R"dx(sqrt)dx"); DOCGROUP(clasp); -CL_DEFUN Number_sp cl__sqrt(Number_sp x) { return clasp_sqrt(x); }; +CL_DEFUN Number_sp cl__sqrt(Number_sp x) { return Number_O::sqrt(x); }; + +CL_LAMBDA(arg); +CL_DECLARE(); +CL_UNWIND_COOP(true); +CL_DOCSTRING(R"dx(abs)dx"); +DOCGROUP(clasp); +CL_DEFUN Number_sp cl__abs(Number_sp x) { return Number_O::abs(x); }; /* ---------------------------------------------------------------------- @@ -1958,12 +1594,12 @@ CL_DEFUN Number_sp cl__sqrt(Number_sp x) { return clasp_sqrt(x); }; See file '../Copyright' for full details. */ -Number_sp Rational_O::sin_() const { return clasp_make_single_float(sinf(this->as_float_())); } +Number_sp Rational_O::sin_() const { return clasp_make_single_float(std::sin(this->as_single_float_())); } -Number_sp DoubleFloat_O::sin_() const { return DoubleFloat_O::create(::sin(this->_Value)); } +Number_sp DoubleFloat_O::sin_() const { return DoubleFloat_O::create(std::sin(this->_Value)); } #ifdef CLASP_LONG_FLOAT -Number_sp LongFloat_O::sin_() const { return LongFloat_O::create(sinl(this->_Value)); } +Number_sp LongFloat_O::sin_() const { return LongFloat_O::create(std::sin(this->_Value)); } #endif Number_sp Complex_O::sin_() const { @@ -1974,8 +1610,8 @@ Number_sp Complex_O::sin_() const { */ Number_sp dx = this->_real; Number_sp dy = this->_imaginary; - Number_sp a = clasp_times(clasp_sin(dx), clasp_cosh(dy)); // clasp_sin(dx), clasp_cosh(dy)); - Number_sp b = clasp_times(clasp_cos(dx), clasp_sinh(dy)); // clasp_cos(dx), clasp_sinh(dy)); + Number_sp a = Number_O::sin(dx) * Number_O::cosh(dy); // clasp_sin(dx), clasp_cosh(dy)); + Number_sp b = Number_O::cos(dx) * Number_O::sinh(dy); // clasp_cos(dx), clasp_sinh(dy)); return clasp_make_complex(gc::As(a), gc::As(b)); } @@ -1984,7 +1620,88 @@ CL_DECLARE(); CL_UNWIND_COOP(true); CL_DOCSTRING(R"dx(sin)dx"); DOCGROUP(clasp); -CL_DEFUN Number_sp cl__sin(Number_sp x) { return clasp_sin(x); } +CL_DEFUN Number_sp cl__sin(Number_sp x) { return Number_O::sin(x); } + +Number_sp Rational_O::asin_() const { return _asin(this->as_single_float_()); } + +Number_sp DoubleFloat_O::asin_() const { return _asin(this->_Value); } + +#ifdef CLASP_LONG_FLOAT +Number_sp LongFloat_O::asin_() const { return _asin(this->_Value); } +#endif + +template inline std::complex _asin2(Float real, Float imag) { +#ifdef _TARGET_OS_DARWIN2 + return (std::fpclassify(real) == FP_ZERO) ? -std::log(-imag + std::sqrt(std::complex(Float{1} + imag, Float{0}))) + : std::asin(std::complex(real, imag)); +#else + return std::asin(std::complex(real, imag)); +#endif +} + +Number_sp Complex_O::asin_() const { +#ifdef CLASP_LONG_FLOAT + if (_real.isA()) + return make_complex(_asin2(_real->as_long_float_(), _imaginary->as_long_float_())); +#endif + if (_real.isA()) + return make_complex(_asin2(_real->as_double_float_(), _imaginary->as_double_float_())); +#ifdef CLASP_SHORT_FLOAT + if (_real.short_floatp()) + return make_complex(_asin2(_real.unsafe_short_float(), _imaginary.unsafe_short_float())); +#endif + return make_complex((std::complex)_asin2(clasp_to_float(_real), clasp_to_float(_imaginary))); +} + +CL_LAMBDA(x); +CL_DECLARE(); +CL_UNWIND_COOP(true); +CL_DOCSTRING(R"dx(asin)dx"); +DOCGROUP(clasp); +CL_DEFUN Number_sp cl__asin(Number_sp x) { return Number_O::asin(x); } + +Number_sp Rational_O::acos_() const { return _acos(this->as_single_float_()); } + +Number_sp DoubleFloat_O::acos_() const { return _acos(this->_Value); } + +#ifdef CLASP_LONG_FLOAT +Number_sp LongFloat_O::acos_() const { return _acos(this->_Value); } +#endif + +template inline std::complex _acos2(Float real, Float imag) { +#ifdef _TARGET_OS_DARWIN2 + return (std::fpclassify(real) == FP_ZERO) + ? std::numbers::pi_v / 2 + std::log(-imag + std::sqrt(std::complex(Float{1} + imag, Float{0}))) + : std::acos(std::complex(real, imag)); +#else + return std::acos(std::complex(real, imag)); +#endif +} + +Number_sp Complex_O::acos_() const { +#ifdef CLASP_LONG_FLOAT + if (_real.isA()) + return make_complex(_acos2(_real->as_long_float_(), _imaginary->as_long_float_())); +#endif + if (_real.isA()) + return make_complex(_acos2(_real->as_double_float_(), _imaginary->as_double_float_())); +#ifdef CLASP_SHORT_FLOAT + if (_real.short_floatp()) + return make_complex(_acos2(_real.unsafe_short_float(), _imaginary.unsafe_short_float())); +#endif +#ifdef _TARGET_OS_DARWIN + return make_complex((std::complex)_acos2(clasp_to_float(_real), clasp_to_float(_imaginary))); +#else + return make_complex(_acos2(clasp_to_float(_real), clasp_to_float(_imaginary))); +#endif +} + +CL_LAMBDA(x); +CL_DECLARE(); +CL_UNWIND_COOP(true); +CL_DOCSTRING(R"dx(acos)dx"); +DOCGROUP(clasp); +CL_DEFUN Number_sp cl__acos(Number_sp x) { return Number_O::acos(x); } /* ---------------------------------------------------------------------- @@ -2009,12 +1726,12 @@ CL_DEFUN Number_sp cl__sin(Number_sp x) { return clasp_sin(x); } See file '../Copyright' for full details. */ -Number_sp Rational_O::cos_() const { return clasp_make_single_float(cosf(this->as_float_())); } +Number_sp Rational_O::cos_() const { return clasp_make_single_float(std::cos(this->as_single_float_())); } -Number_sp DoubleFloat_O::cos_() const { return DoubleFloat_O::create(::cos(this->_Value)); } +Number_sp DoubleFloat_O::cos_() const { return DoubleFloat_O::create(std::cos(this->_Value)); } #ifdef CLASP_LONG_FLOAT -Number_sp LongFloat_O::cos_() const { return LongFloat_O::create(cosl(this->_Value)); } +Number_sp LongFloat_O::cos_() const { return LongFloat_O::create(std::cos(this->_Value)); } #endif Number_sp Complex_O::cos_() const { @@ -2023,9 +1740,9 @@ Number_sp Complex_O::cos_() const { */ Number_sp dx = this->_real; Number_sp dy = this->_imaginary; - Number_sp a = clasp_times(clasp_cos(dx), clasp_cosh(dy)); // clasp_cos(dx), clasp_cosh(dy)); - Number_sp b = clasp_times(clasp_negate(clasp_sin(dx)), clasp_sinh(dy)); // clasp_negate(clasp_sin(dx)), clasp_sinh(dy)); - return clasp_make_complex(gc::As(a), gc::As(b)); // clasp_make_complex(a, b); + Number_sp a = Number_O::cos(dx) * Number_O::cosh(dy); // clasp_cos(dx), clasp_cosh(dy)); + Number_sp b = clasp_negate(Number_O::sin(dx)) * Number_O::sinh(dy); // clasp_negate(clasp_sin(dx)), clasp_sinh(dy)); + return clasp_make_complex(gc::As(a), gc::As(b)); // clasp_make_complex(a, b); } CL_LAMBDA(x); @@ -2033,7 +1750,7 @@ CL_DECLARE(); CL_UNWIND_COOP(true); CL_DOCSTRING(R"dx(cos)dx"); DOCGROUP(clasp); -CL_DEFUN Number_sp cl__cos(Number_sp x) { return clasp_cos(x); } +CL_DEFUN Number_sp cl__cos(Number_sp x) { return Number_O::cos(x); } /* ---------------------------------------------------------------------- @@ -2069,18 +1786,18 @@ static double safe_tanf(double x) { return tan(x); } #define safe_tanf(x) tanf(x) #endif -Number_sp Rational_O::tan_() const { return clasp_make_single_float(safe_tanf(this->as_float_())); } +Number_sp Rational_O::tan_() const { return clasp_make_single_float(safe_tanf(this->as_single_float_())); } -Number_sp DoubleFloat_O::tan_() const { return DoubleFloat_O::create(::tan(this->_Value)); } +Number_sp DoubleFloat_O::tan_() const { return DoubleFloat_O::create(std::tan(this->_Value)); } #ifdef CLASP_LONG_FLOAT -Number_sp LongFloat_O::tan_() const { return LongFloat_O::create(tanl(this->_Value)); } +Number_sp LongFloat_O::tan_() const { return LongFloat_O::create(std::tan(this->_Value)); } #endif Number_sp Complex_O::tan_() const { Number_sp a = this->sin_(); Number_sp b = this->cos_(); - return clasp_divide(a, b); + return a / b; } CL_LAMBDA(x); @@ -2088,7 +1805,7 @@ CL_DECLARE(); CL_UNWIND_COOP(true); CL_DOCSTRING(R"dx(tan)dx"); DOCGROUP(clasp); -CL_DEFUN Number_sp cl__tan(Number_sp x) { return clasp_tan(x); } +CL_DEFUN Number_sp cl__tan(Number_sp x) { return Number_O::tan(x); } /* ---------------------------------------------------------------------- @@ -2111,12 +1828,12 @@ CL_DEFUN Number_sp cl__tan(Number_sp x) { return clasp_tan(x); } See file '../Copyright' for full details. */ -Number_sp Rational_O::sinh_() const { return clasp_make_single_float(sinhf(this->as_float_())); } +Number_sp Rational_O::sinh_() const { return clasp_make_single_float(std::sinh(this->as_single_float_())); } -Number_sp DoubleFloat_O::sinh_() const { return DoubleFloat_O::create(::sinh(this->_Value)); } +Number_sp DoubleFloat_O::sinh_() const { return DoubleFloat_O::create(std::sinh(this->_Value)); } #ifdef CLASP_LONG_FLOAT -Number_sp LongFloat_O::sinh_() const { return LongFloat_O::create(sinhl(this->_Value)); } +Number_sp LongFloat_O::sinh_() const { return LongFloat_O::create(std::sinh(this->_Value)); } #endif Number_sp Complex_O::sinh_() const { @@ -2128,8 +1845,8 @@ Number_sp Complex_O::sinh_() const { */ Number_sp dx = this->_real; Number_sp dy = this->_imaginary; - Number_sp a = clasp_times(clasp_sinh(dx), clasp_cos(dy)); - Number_sp b = clasp_times(clasp_cosh(dx), clasp_sin(dy)); + Number_sp a = Number_O::sinh(dx) * Number_O::cos(dy); + Number_sp b = Number_O::cosh(dx) * Number_O::sin(dy); return clasp_make_complex(gc::As(a), gc::As(b)); } @@ -2138,7 +1855,7 @@ CL_DECLARE(); CL_UNWIND_COOP(true); CL_DOCSTRING(R"dx(sinh)dx"); DOCGROUP(clasp); -CL_DEFUN Number_sp cl__sinh(Number_sp x) { return clasp_sinh(x); } +CL_DEFUN Number_sp cl__sinh(Number_sp x) { return Number_O::sinh(x); } /* ---------------------------------------------------------------------- @@ -2161,12 +1878,12 @@ CL_DEFUN Number_sp cl__sinh(Number_sp x) { return clasp_sinh(x); } See file '../Copyright' for full details. */ -Number_sp Rational_O::cosh_() const { return clasp_make_single_float(coshf(this->as_float_())); } +Number_sp Rational_O::cosh_() const { return clasp_make_single_float(std::cosh(this->as_single_float_())); } -Number_sp DoubleFloat_O::cosh_() const { return DoubleFloat_O::create(::cosh(this->_Value)); } +Number_sp DoubleFloat_O::cosh_() const { return DoubleFloat_O::create(std::cosh(this->_Value)); } #ifdef CLASP_LONG_FLOAT -Number_sp LongFloat_O::cosh_() const { return LongFloat_O::create(coshl(this->_Value)); } +Number_sp LongFloat_O::cosh_() const { return LongFloat_O::create(std::cosh(this->_Value)); } #endif Number_sp Complex_O::cosh_() const { @@ -2178,8 +1895,8 @@ Number_sp Complex_O::cosh_() const { */ Number_sp dx = this->_real; Number_sp dy = this->_imaginary; - Number_sp a = clasp_times(clasp_cosh(dx), clasp_cos(dy)); // clasp_cosh(dx), clasp_cos(dy)); - Number_sp b = clasp_times(clasp_sinh(dx), clasp_sin(dy)); // clasp_sinh(dx), clasp_sin(dy)); + Number_sp a = Number_O::cosh(dx) * Number_O::cos(dy); // Number_O::cosh(dx), Number_O::cos(dy)); + Number_sp b = Number_O::sinh(dx) * Number_O::sin(dy); // Number_O::sinh(dx), Number_O::sin(dy)); return clasp_make_complex(gc::As(a), gc::As(b)); // clasp_make_complex(a, b); } @@ -2188,7 +1905,7 @@ CL_DECLARE(); CL_UNWIND_COOP(true); CL_DOCSTRING(R"dx(cosh)dx"); DOCGROUP(clasp); -CL_DEFUN Number_sp cl__cosh(Number_sp x) { return clasp_cosh(x); } +CL_DEFUN Number_sp cl__cosh(Number_sp x) { return Number_O::cosh(x); } /* ---------------------------------------------------------------------- @@ -2212,18 +1929,18 @@ CL_DEFUN Number_sp cl__cosh(Number_sp x) { return clasp_cosh(x); } See file '../Copyright' for full details. */ -Number_sp Rational_O::tanh_() const { return clasp_make_single_float(tanhf(this->as_float_())); } +Number_sp Rational_O::tanh_() const { return clasp_make_single_float(std::tanh(this->as_single_float_())); } -Number_sp DoubleFloat_O::tanh_() const { return DoubleFloat_O::create(::tanh(this->_Value)); } +Number_sp DoubleFloat_O::tanh_() const { return DoubleFloat_O::create(std::tanh(this->_Value)); } #ifdef CLASP_LONG_FLOAT -Number_sp LongFloat_O::tanh_() const { return LongFloat_O::create(tanhl(this->_Value)); } +Number_sp LongFloat_O::tanh_() const { return LongFloat_O::create(std::tanh(this->_Value)); } #endif Number_sp Complex_O::tanh_() const { Number_sp a = this->sinh_(); Number_sp b = this->cosh_(); - return clasp_divide(a, b); + return a / b; } CL_LAMBDA(x); @@ -2231,7 +1948,7 @@ CL_DECLARE(); CL_UNWIND_COOP(true); CL_DOCSTRING(R"dx(tanh)dx"); DOCGROUP(clasp); -CL_DEFUN Number_sp cl__tanh(Number_sp x) { return clasp_tanh(x); } +CL_DEFUN Number_sp cl__tanh(Number_sp x) { return Number_O::tanh(x); } /* ---------------------------------------------------------------------- @@ -2289,22 +2006,17 @@ CL_DEFUN Number_sp cl__conjugate(Number_sp x) { return clasp_conjugate(x); } See file '../Copyright' for full details. */ -Number_sp Rational_O::exp_() const { return clasp_make_single_float(expf(this->as_float_())); } +Number_sp Rational_O::exp_() const { return clasp_make_single_float(std::exp(this->as_single_float_())); } -Number_sp DoubleFloat_O::exp_() const { return DoubleFloat_O::create(::exp(this->_Value)); } +Number_sp DoubleFloat_O::exp_() const { return DoubleFloat_O::create(std::exp(this->_Value)); } #ifdef CLASP_LONG_FLOAT -Number_sp LongFloat_O::exp_() const { return LongFloat_O::create(expl(this->_Value)); } +Number_sp LongFloat_O::exp_() const { return LongFloat_O::create(std::exp(this->_Value)); } #endif Number_sp Complex_O::exp_() const { - Real_sp y, y1; - y = this->_imaginary; - Real_sp x = gc::As(clasp_exp(this->_real)); - y1 = gc::As(clasp_cos(y)); // clasp_cos(y); - y = gc::As(clasp_sin(y)); // clasp_sin(y); - Complex_sp cy = gc::As_unsafe(clasp_make_complex(y1, y)); - return clasp_times(x, cy); + return clasp_exp(_real) * + clasp_make_complex(Number_O::cos(_imaginary).as_unsafe(), Number_O::sin(_imaginary).as_unsafe()); } CL_LAMBDA(x); @@ -2352,56 +2064,53 @@ Fixnum clasp_fixnum_expt(Fixnum x, Fixnum y) { } static Number_sp expt_zero(Number_sp x, Number_sp y) { - NumberType ty, tx; - Number_sp z; - ty = clasp_t_of(y); - tx = clasp_t_of(x); - /* INV: The most specific numeric types come first. */ - switch ((ty > tx) ? ty : tx) { - case number_Fixnum: - case number_Bignum: - case number_Ratio: - return clasp_make_fixnum(1); - case number_SingleFloat: - return clasp_make_single_float(1.0f); - case number_DoubleFloat: - return DoubleFloat_O::create(1.0); + Complex_sp cx = x.asOrNull(), cy = y.asOrNull(); + if (cx && cy) + return clasp_make_complex(expt_zero(cx->real(), cy->real()).as_unsafe(), clasp_make_fixnum(0)); + if (cx) + return clasp_make_complex(expt_zero(cx->real(), y).as_unsafe(), clasp_make_fixnum(0)); + if (cy) + return clasp_make_complex(expt_zero(x, cy->real()).as_unsafe(), clasp_make_fixnum(0)); + #ifdef CLASP_LONG_FLOAT - case number_LongFloat: - return LongFloat_O::create(1.0); + if (x.isA() || y.isA()) + return LongFloat_O::create(long_float_t{1}); #endif - case number_Complex: - z = expt_zero((tx == number_Complex) ? gc::As(gc::As(x)->real()) : x, - (ty == number_Complex) ? gc::As(gc::As(y)->real()) : y); - return clasp_make_complex(gc::As(z), clasp_make_fixnum(0)); - default: - UNREACHABLE(); - } + + if (x.isA() || y.isA()) + return DoubleFloat_O::create(double_float_t{1}); + + if (x.single_floatp() || y.single_floatp()) + return SingleFloat_dummy_O::create(single_float_t{1}); + +#ifdef CLASP_SHORT_FLOAT + if (x.short_floatp() || y.short_floatp()) + return ShortFloat_O::create(short_float_t{1}); +#endif + + return clasp_make_fixnum(1); } Number_sp clasp_expt(Number_sp x, Number_sp y) { - NumberType ty, tx; - Number_sp z; - if (clasp_unlikely(clasp_zerop(y))) { + if (clasp_unlikely(Number_O::zerop(y))) { return expt_zero(x, y); } - ty = clasp_t_of(y); - tx = clasp_t_of(x); - if (clasp_zerop(x)) { - z = clasp_times(x, y); - if (!clasp_plusp((ty == number_Complex) ? gc::As(y)->real() : gc::As(y))) - z = clasp_divide(clasp_make_fixnum(1), z); - } else if (ty != number_Fixnum && ty != number_Bignum) { + Number_sp z; + if (Number_O::zerop(x)) { + z = x * y; + if (!Real_O::plusp(y.isA() ? y.as_unsafe()->real() : y.as())) + z = clasp_make_fixnum(1) / z; + } else if (!y.isA()) { // Use the general definition, a^b = exp(b log(a)) /* The following could be just z = clasp_log1(x); however, Maxima expects EXPT to have double accuracy when the first argument is integer and the second is double-float */ - z = clasp_log1(clasp_times(x, expt_zero(x, y))); - z = clasp_times(z, y); + z = clasp_log1(x * expt_zero(x, y)); + z = z * y; z = cl__exp(z); - } else if (clasp_minusp(gc::As(y))) { + } else if (Real_O::minusp(y.as())) { z = clasp_negate(y); z = clasp_expt(x, z); z = clasp_reciprocal(z); @@ -2410,12 +2119,12 @@ Number_sp clasp_expt(Number_sp x, Number_sp y) { Integer_sp iy = gc::As(y); do { // Exponentiation by squaring. - if (!clasp_evenp(iy)) - z = clasp_times(z, x); + if (!Integer_O::evenp(iy)) + z = z * x; iy = clasp_shift_right(iy, 1); // divide by two - if (clasp_zerop(iy)) + if (Number_O::zerop(iy)) break; - x = clasp_times(x, x); + x = x * x; } while (1); } return z; @@ -2448,112 +2157,52 @@ CL_DEFUN Number_sp cl__expt(Number_sp x, Number_sp y) { return clasp_expt(x, y); See file '../Copyright' for full details. */ -Number_sp clasp_atan2(Number_sp y, Number_sp x) { - MATH_DISPATCH_BEGIN(x, y) { - case_Bignum_v_ShortFloat: - case_Fixnum_v_ShortFloat: - case_Ratio_v_ShortFloat: - case_ShortFloat_v_Bignum: - case_ShortFloat_v_Fixnum: - case_ShortFloat_v_Ratio: - case_ShortFloat_v_ShortFloat: - case_Bignum_v_Bignum: - case_Bignum_v_Fixnum: - case_Bignum_v_Ratio: - case_Bignum_v_SingleFloat: - case_Fixnum_v_Bignum: - case_Fixnum_v_Fixnum: - case_Fixnum_v_Ratio: - case_Fixnum_v_SingleFloat: - case_Ratio_v_Bignum: - case_Ratio_v_Fixnum: - case_Ratio_v_Ratio: - case_Ratio_v_SingleFloat: - case_ShortFloat_v_SingleFloat: - case_SingleFloat_v_Bignum: - case_SingleFloat_v_Fixnum: - case_SingleFloat_v_Ratio: - case_SingleFloat_v_ShortFloat: - case_SingleFloat_v_SingleFloat: +Number_sp Number_O::atan2(Real_sp y, Real_sp x) { +#ifdef CLASP_LONG_FLOAT + if (x.isA() || y.isA()) + return LongFloat_O::create(std::atan2(as_long_float(y), as_long_float(x))); +#endif + + if (x.isA() || y.isA()) + return DoubleFloat_O::create(std::atan2(as_double_float(y), as_double_float(x))); + +#ifdef CLASP_SHORT_FLOAT + if ((na.short_floatp() && !nb.single_floatp()) || (!na.single_floatp() && nb.short_floatp())) + return ShortFloat_O::create(std::atan2(as_short_float(y), as_short_float(x))); +#endif + #ifdef _TARGET_OS_DARWIN - return clasp_make_single_float(atan2(clasp_to_double(y), clasp_to_double(x))); + return SingleFloat_dummy_O::create(std::atan2(as_double_float(y), as_double_float(x))); #else - return clasp_make_single_float(atan2f(clasp_to_float(y), clasp_to_float(x))); -#endif - case_Bignum_v_LongFloat: - case_DoubleFloat_v_LongFloat: - case_Fixnum_v_LongFloat: - case_LongFloat_v_Bignum: - case_LongFloat_v_DoubleFloat: - case_LongFloat_v_Fixnum: - case_LongFloat_v_LongFloat: - case_LongFloat_v_Ratio: - case_LongFloat_v_ShortFloat: - case_LongFloat_v_SingleFloat: - case_Ratio_v_LongFloat: - case_ShortFloat_v_LongFloat: - case_SingleFloat_v_LongFloat: -#ifdef CLASP_LONG_FLOAT - return clasp_make_long_float(atan2l(clasp_to_long_float(y), clasp_to_long_float(x))); -#endif - case_Bignum_v_DoubleFloat: - case_DoubleFloat_v_Bignum: - case_DoubleFloat_v_DoubleFloat: - case_DoubleFloat_v_Fixnum: - case_DoubleFloat_v_Ratio: - case_DoubleFloat_v_ShortFloat: - case_DoubleFloat_v_SingleFloat: - case_Fixnum_v_DoubleFloat: - case_Ratio_v_DoubleFloat: - case_ShortFloat_v_DoubleFloat: - case_SingleFloat_v_DoubleFloat: - return clasp_make_double_float(atan2(clasp_to_double(y), clasp_to_double(x))); - default: - TYPE_ERROR(gctools::IsA(y) ? x : y, cl::_sym_Real_O); - } - MATH_DISPATCH_END(); -} - -Number_sp clasp_atan1(Number_sp y) { - switch (clasp_t_of(y)) { - case number_ShortFloat: - case number_Bignum: - case number_Fixnum: - case number_Ratio: - case number_SingleFloat: + return SingleFloat_dummy_O::create(std::atan2(as_single_float(y), as_single_float(x))); +#endif +} + +Number_sp Rational_O::atan_() const { #ifdef _TARGET_OS_DARWIN - return clasp_make_single_float(atan(clasp_to_double(y))); + return SingleFloat_dummy_O::create(std::atan(as_double_float_())); #else - return clasp_make_single_float(atanf(clasp_to_float(y))); + return SingleFloat_dummy_O::create(std::atan(as_single_float_())); #endif - case number_LongFloat: +} + +Number_sp DoubleFloat_O::atan_() const { return DoubleFloat_O::create(std::atan(_Value)); } + #ifdef CLASP_LONG_FLOAT - return clasp_make_long_float(atanl(clasp_to_long_float(y))); -#endif - case number_DoubleFloat: - return clasp_make_double_float(atan(clasp_to_double(y))); - case number_Complex: { - Number_sp z = clasp_times(_lisp->imaginaryUnit(), y); -#if 0 /* ANSI states it should be this first part */ - z = clasp_plus(clasp_log1(clasp_one_plus(z)), - clasp_log1(clasp_minus(clasp_make_fixnum(1), z))); - z = clasp_divide(z, clasp_times(clasp_make_fixnum(2), - cl_core.imag_unit)); -#else - Number_sp z1; - z = clasp_one_plus(z); - z1 = clasp_times(y, y); - z1 = clasp_one_plus(z1); - z1 = clasp_sqrt(z1); - z = clasp_divide(z, z1); - z = clasp_log1(z); - z = clasp_times(_lisp->imaginaryUnitNegative(), z); -#endif /* ANSI */ - return z; - } - default: - TYPE_ERROR(y, cl::_sym_Number_O); - } +Number_sp LongFloat_O::atan_() const { return LongFloat_O::create(std::atan(_Value)); } +#endif + +Number_sp Complex_O::atan_() const { + Number_sp z = _lisp->imaginaryUnit().as_unsafe() * asSmartPtr(); + Number_sp z1; + z = clasp_one_plus(z); + z1 = asSmartPtr().as_unsafe() * asSmartPtr().as_unsafe(); + z1 = clasp_one_plus(z1); + z1 = Number_O::sqrt(z1); + z = z / z1; + z = clasp_log1(z); + z = _lisp->imaginaryUnitNegative() * z; + return z; } CL_LAMBDA(x &optional (y nil yp)); @@ -2563,10 +2212,10 @@ CL_DOCSTRING(R"dx(atan)dx"); DOCGROUP(clasp); CL_DEFUN Number_sp cl__atan(Number_sp x, T_sp y, bool yp) { if (!yp) - return clasp_atan1(x); + return Number_O::atan(x); - if (gctools::IsA(y)) - return clasp_atan2(x, y.as_unsafe()); + if (gctools::IsA(y)) + return Number_O::atan2(x.as_unsafe(), y.as_unsafe()); TYPE_ERROR(y, cl::_sym_Number_O); } @@ -2591,9 +2240,9 @@ CL_DEFUN Number_sp cl__atan(Number_sp x, T_sp y, bool yp) { */ Number_sp clasp_log1_complex_inner(Number_sp r, Number_sp i) { - Real_sp a = gc::As(clasp_abs(r)); - Real_sp p = gc::As(clasp_abs(i)); - int rel = clasp_number_compare(a, p); + Real_sp a = gc::As(Number_O::abs(r)); + Real_sp p = gc::As(Number_O::abs(i)); + int rel = Number_O::compare(a, p); if (rel > 0) { Real_sp aux = p; p = a; @@ -2602,17 +2251,17 @@ Number_sp clasp_log1_complex_inner(Number_sp r, Number_sp i) { /* if a == p, * log(sqrt(a^2+p^2)) = log(2a^2)/2 */ - a = gc::As(clasp_times(a, a)); - a = gc::As(clasp_divide(clasp_log1(clasp_plus(a, a)), make_fixnum(2))); + a = gc::As(a * a); + a = gc::As(clasp_log1(a + a) / make_fixnum(2)); goto OUTPUT; } /* For the real part of the output we use the formula * log(sqrt(p^2 + a^2)) = log(sqrt(p^2*(1 + (a/p)^2))) * = log(p) + log(1 + (a/p)^2)/2; */ - a = gc::As(clasp_divide(a, p)); - a = gc::As(clasp_plus(clasp_divide(clasp_log1p(clasp_times(a, a)), make_fixnum(2)), clasp_log1(p))); + a = gc::As(a / p); + a = gc::As(clasp_log1p(a * a) / make_fixnum(2) + clasp_log1(p)); OUTPUT: - p = gc::As(clasp_atan2(i, r)); + p = gc::As(Number_O::atan2(i.as_unsafe(), r.as_unsafe())); return clasp_make_complex(a, p); } @@ -2637,29 +2286,27 @@ Number_sp Bignum_O::log1_() const { } Number_sp Rational_O::log1_() const { - float f = this->as_float_(); + float f = this->as_single_float_(); if (f < 0) return clasp_log1_complex_inner(this->asSmartPtr(), clasp_make_fixnum(0)); - return clasp_make_single_float(logf(this->as_float_())); + return clasp_make_single_float(logf(this->as_single_float_())); } Number_sp DoubleFloat_O::log1_() const { - double f = this->as_double_(); - if (std::isnan(f)) + if (std::isnan(_Value)) return this->asSmartPtr(); - if (f < 0) + if (_Value < 0) return clasp_log1_complex_inner(this->asSmartPtr(), clasp_make_fixnum(0)); - return clasp_make_double_float(log(f)); + return clasp_make_double_float(std::log(_Value)); } #ifdef CLASP_LONG_FLOAT Number_sp LongFloat_O::log1_() const { - LongFloat f = this->as_long_float(); - if (std::isnan(f)) + if (std::isnan(_Value)) return this->asSmartPtr(); - if (f < 0) + if (_Value < 0) return clasp_log1_complex_inner(this->asSmartPtr(), clasp_make_fixnum(0)); - return clasp_make_long_float(logl(f)); + return clasp_make_long_float(std::log(_Value)); } #endif @@ -2668,57 +2315,37 @@ Number_sp Complex_O::log1_() const { return clasp_log1_complex_inner(this->real( Number_sp Number_O::log1p_() const { return clasp_log1_complex_inner(clasp_one_plus(this->asSmartPtr()), clasp_make_fixnum(0)); } Number_sp Rational_O::log1p_() const { - float f = this->as_float_(); + float f = this->as_single_float_(); if (f < -1) return this->Base::log1p_(); return clasp_make_single_float(_log1p(f)); } -// translated from ECL cl_rational -Rational_sp DoubleFloat_O::rational(double d) { - if (d == 0) { - return clasp_make_fixnum(0); - } - int e; - d = frexp(d, &e); - e -= DBL_MANT_DIG; - Integer_sp x = _clasp_double_to_integer(ldexp(d, DBL_MANT_DIG)); -#if 0 //(FLT_RADIX == 2) // runtime is sane (or at least IEEE 754) - if (e > 0) - return clasp_shift_left(x, e); - else if (e < 0) - // Efficiency note: This could be done faster by exploiting the fact - // that the denominator is a power of two. Rather than take the full - // gcd, you can just shift out any shared less significant zero bits. - return Rational_O::create(x, clasp_shift_left(clasp_make_fixnum(1), -e)); - else return x; -#else - Number_sp radixexp = clasp_expt(clasp_make_fixnum(FLT_RADIX), clasp_make_fixnum(e)); - return gc::As_unsafe(clasp_times(x, radixexp)); +Rational_sp DoubleFloat_O::as_rational_() const { return float_to_rational(_Value); } + +#ifdef CLASP_LONG_FLOAT +Rational_sp LongFloat_O::as_rational_() const { return float_to_rational(_Value); } #endif -} Number_sp DoubleFloat_O::log1p_() const { - double f = this->as_double_(); - if (std::isnan(f)) + if (std::isnan(_Value)) return this->asSmartPtr(); - if (f < -1) + if (_Value < -1) return clasp_log1_complex_inner(clasp_one_plus(this->asSmartPtr()), clasp_make_fixnum(0)); - return clasp_make_double_float(_log1p(f)); + return clasp_make_double_float(_log1p(_Value)); } #ifdef CLASP_LONG_FLOAT -Number_sp LongFloat_O::log1p() const { - LongFloat f = this->as_long_float(); - if (std::isnan(f)) +Number_sp LongFloat_O::log1p_() const { + if (std::isnan(_Value)) return this->asSmartPtr(); - if (f < -1) + if (_Value < -1) return clasp_log1_complex_inner(clasp_one_plus(this->asSmartPtr()), clasp_make_fixnum(0)); - return clasp_make_long_float(_log1p(f)); + return clasp_make_long_float(_log1p(_Value)); } #endif -Number_sp clasp_log2(Number_sp x, Number_sp y) { return clasp_divide(clasp_log1(y), clasp_log1(x)); } +Number_sp clasp_log2(Number_sp x, Number_sp y) { return clasp_log1(y) / clasp_log1(x); } Number_sp Complex_O::log1p_() const { return clasp_log1_complex_inner(clasp_one_plus(this->real()), this->imaginary()); } @@ -2780,16 +2407,14 @@ CL_DECLARE(); CL_UNWIND_COOP(true); CL_DOCSTRING(R"dx(doc(float-nan-p)dx"); DOCGROUP(clasp); -CL_DEFUN bool ext__float_nan_p(Float_sp i) { - return clasp_float_nan_p(i); -}; +CL_DEFUN bool ext__float_nan_p(Float_sp i) { return Float_O::isnan(i); }; CL_LAMBDA(i); CL_DECLARE(); CL_UNWIND_COOP(true); CL_DOCSTRING(R"dx(float-infinity-p)dx"); DOCGROUP(clasp); -CL_DEFUN bool ext__float_infinity_p(Float_sp i) { return clasp_float_infinity_p(i); }; +CL_DEFUN bool ext__float_infinity_p(Float_sp i) { return Float_O::isinf(i); }; SYMBOL_EXPORT_SC_(ClPkg, sqrt); SYMBOL_EXPORT_SC_(ClPkg, sin); @@ -2848,7 +2473,7 @@ float clasp_to_float(core::Number_sp x) { if (x.single_floatp()) { return (float)x.unsafe_single_float(); } - return x->as_float_(); + return x->as_single_float_(); } double clasp_to_double(core::Number_sp x) { @@ -2859,7 +2484,7 @@ double clasp_to_double(core::Number_sp x) { double d = x.unsafe_single_float(); return d; } - return x->as_double_(); + return x->as_double_float_(); }; double clasp_to_double(core::Integer_sp x) { @@ -2867,7 +2492,7 @@ double clasp_to_double(core::Integer_sp x) { double d = x.unsafe_fixnum(); return d; } - return x->as_double_(); + return x->as_double_float_(); }; double clasp_to_double(core::T_sp x) { @@ -2878,7 +2503,7 @@ double clasp_to_double(core::T_sp x) { double d = x.unsafe_single_float(); return d; } else if (gc::IsA(x)) { - return gc::As_unsafe(x)->as_double_(); + return gc::As_unsafe(x)->as_double_float_(); } TYPE_ERROR(x, cl::_sym_Number_O); } @@ -2891,33 +2516,62 @@ double clasp_to_double(core::Real_sp x) { double d = x.unsafe_single_float(); return d; } else if (gc::IsA(x)) { - return gc::As_unsafe(x)->as_double_(); + return gc::As_unsafe(x)->as_double_float_(); } TYPE_ERROR(x, Cons_O::createList(cl::_sym_Real_O)); } double clasp_to_double(core::General_sp x) { if (gc::IsA(x)) { - return gc::As_unsafe(x)->as_double_(); + return gc::As_unsafe(x)->as_double_float_(); } TYPE_ERROR(x, cl::_sym_Number_O); }; double clasp_to_double(core::DoubleFloat_sp x) { return x->get(); }; -LongFloat clasp_to_long_float(Number_sp x) { return x->as_long_float_(); }; +long_float_t clasp_to_long_float(Number_sp x) { + if (x.fixnump()) + return (long_float_t)x.unsafe_fixnum(); + + if (x.single_floatp()) + return (long_float_t)x.unsafe_single_float(); -LongFloat clasp_to_long_double(Number_sp x) { return x->as_long_float_(); }; + if (x.isA()) + return x->as_long_float_(); + + TYPE_ERROR(x, cl::_sym_Real_O); +}; // --- END OF TRANSLATORS --- +#ifdef CLASP_SHORT_FLOAT +CL_LAMBDA(float); +CL_DECLARE(); +CL_UNWIND_COOP(true); +CL_DOCSTRING(R"dx(Return the bit representation of a short float as an integer.)dx"); +DOCGROUP(clasp); +CL_DEFUN Integer_sp ext__short_float_to_bits(ShortFloat_sp x) { + return Integer_O::create(float_convert::float_to_bits(x.unsafe_short_float())); +} + +CL_LAMBDA(bit-representation); +CL_DECLARE(); +CL_UNWIND_COOP(true); +CL_DOCSTRING(R"dx(Convert a bit representation, an integer, to a short float.)dx"); +DOCGROUP(clasp); +CL_DEFUN LongFloat_sp ext__bits_to_short_float(Integer_sp integer) { + return ShortFloat_O::create(float_convert::bits_to_float(clasp_to_uint16_t(integer))); +} +#endif + CL_LAMBDA(singleFloat); CL_DECLARE(); CL_UNWIND_COOP(true); CL_DOCSTRING(R"dx(Return the IEEE754 binary32 (single) representation of a single float, as an integer.)dx"); DOCGROUP(clasp); CL_DEFUN Integer_sp ext__single_float_to_bits(SingleFloat_sp singleFloat) { - return Integer_O::create(float_convert::to_bits(unbox_single_float(singleFloat))); + return Integer_O::create(float_convert::float_to_bits(unbox_single_float(singleFloat))); } CL_LAMBDA(bit-representation); @@ -2926,7 +2580,7 @@ CL_UNWIND_COOP(true); CL_DOCSTRING(R"dx(Convert an IEEE754 binary32 (single) representation, an integer, to a single float.)dx"); DOCGROUP(clasp); CL_DEFUN SingleFloat_sp ext__bits_to_single_float(Integer_sp integer) { - return make_single_float(float_convert::from_bits(clasp_to_uint32_t(integer))); + return make_single_float(float_convert::bits_to_float(clasp_to_uint32_t(integer))); }; CL_LAMBDA(doubleFloat); @@ -2935,7 +2589,7 @@ CL_UNWIND_COOP(true); CL_DOCSTRING(R"dx(Return the IEEE754 binary64 (double) bit representation of a double float as an integer.)dx"); DOCGROUP(clasp); CL_DEFUN Integer_sp ext__double_float_to_bits(DoubleFloat_sp doubleFloat) { - return Integer_O::create(float_convert::to_bits(doubleFloat->get())); + return Integer_O::create(float_convert::float_to_bits(doubleFloat->get())); } CL_LAMBDA(bit-representation); @@ -2944,8 +2598,28 @@ CL_UNWIND_COOP(true); CL_DOCSTRING(R"dx(Convert an IEEE754 binary64 (double) representation, an integer, to a double float.)dx"); DOCGROUP(clasp); CL_DEFUN DoubleFloat_sp ext__bits_to_double_float(Integer_sp integer) { - return clasp_make_double_float(float_convert::from_bits(clasp_to_uint64_t(integer))); + return clasp_make_double_float(float_convert::bits_to_float(clasp_to_uint64_t(integer))); +} + +#ifdef CLASP_LONG_FLOAT +CL_LAMBDA(longFloat); +CL_DECLARE(); +CL_UNWIND_COOP(true); +CL_DOCSTRING(R"dx(Return the bit representation of a long float as an integer.)dx"); +DOCGROUP(clasp); +CL_DEFUN Integer_sp ext__long_float_to_bits(LongFloat_sp longFloat) { + return Integer_O::create(float_convert::float_to_bits(longFloat->get())); +} + +CL_LAMBDA(bit-representation); +CL_DECLARE(); +CL_UNWIND_COOP(true); +CL_DOCSTRING(R"dx(Convert a bit representation, an integer, to a long float.)dx"); +DOCGROUP(clasp); +CL_DEFUN LongFloat_sp ext__bits_to_long_float(Integer_sp integer) { + return clasp_make_long_float(float_convert::bits_to_float(clasp_to_integral<__uint128_t>(integer))); } +#endif }; // namespace core @@ -2953,20 +2627,74 @@ namespace core { CL_UNWIND_COOP(true); DOCGROUP(clasp); -CL_DEFUN Number_sp cl__rational(Real_sp num) { - if (num.fixnump()) - return num; - if (num.single_floatp()) - return DoubleFloat_O::rational(num.unsafe_single_float()); - if (gc::IsA(num)) - return gc::As_unsafe(num)->rational_(); - TYPE_ERROR(num, cl::_sym_Real_O); -}; +CL_DEFUN Rational_sp cl__rational(Real_sp num) { return Rational_O::coerce(num); } CL_UNWIND_COOP(true); DOCGROUP(clasp); -CL_DEFUN Number_sp cl__rationalize(Real_sp num) { return cl__rational(num); }; +CL_DEFUN Rational_sp cl__rationalize(Real_sp num) { return Rational_O::coerce(num); }; Integer_sp clasp_make_integer(size_t s) { return Integer_O::create((uint64_t)s); } +#ifdef CLASP_SHORT_FLOAT +ShortFloat_sp ShortFloat_dummy_O::coerce(Number_sp x) { + if (x.fixnump()) + return create(x.unsafe_fixnum()); + if (x.short_floatp()) + return gc::As_unsafe(x); + if (x.single_floatp()) + return create((short_float_t)x.unsafe_single_float()); + if (x.isA()) + return create(x->as_short_float_()); + TYPE_ERROR(x, cl::_sym_Real_O); +} +#endif + +SingleFloat_sp SingleFloat_dummy_O::coerce(Number_sp x) { + if (x.fixnump()) + return create(x.unsafe_fixnum()); +#ifdef CLASP_SHORT_FLOAT + if (x.short_floatp()) + return create((single_float_t)x.unsafe_short_float()); +#endif + if (x.single_floatp()) + return gc::As_unsafe(x); + if (x.isA()) + return create(x->as_single_float_()); + TYPE_ERROR(x, cl::_sym_Real_O); +} + +DoubleFloat_sp DoubleFloat_O::coerce(Number_sp x) { + if (x.fixnump()) + return create(x.unsafe_fixnum()); +#ifdef CLASP_SHORT_FLOAT + if (x.short_floatp()) + return create((double_float_t)x.unsafe_short_float()); +#endif + if (x.single_floatp()) + return create(x.unsafe_single_float()); + if (x.isA()) + return x.as_unsafe(); + if (x.isA()) + return create(x->as_double_float_()); + TYPE_ERROR(x, cl::_sym_Real_O); +} + +#ifdef CLASP_LONG_FLOAT +LongFloat_sp LongFloat_O::coerce(Number_sp x) { + if (x.fixnump()) + return create(x.unsafe_fixnum()); +#ifdef CLASP_SHORT_FLOAT + if (x.short_floatp()) + return create((long_float_t)x.unsafe_short_float()); +#endif + if (x.single_floatp()) + return create(x.unsafe_single_float()); + if (x.isA()) + return x.as_unsafe(); + if (x.isA()) + return create(x->as_long_float_()); + TYPE_ERROR(x, cl::_sym_Real_O); +} +#endif + }; // namespace core diff --git a/src/core/numerics.cc b/src/core/numerics.cc index d4920f7658..284790790a 100644 --- a/src/core/numerics.cc +++ b/src/core/numerics.cc @@ -98,7 +98,7 @@ vector bignumToMixedBaseDigits(const Bignum& index, const vector& base } CL_DEFUN List_sp core__positive_integer_to_mixed_base_digits(core::Integer_sp number, List_sp bases) { - if (!(clasp_zerop(number) || clasp_plusp(number))) { + if (!(Number_O::zerop(number) || Real_O::plusp(number))) { SIMPLE_ERROR("The number {} must be zero or positive", _rep_(number)); } vector ibases; @@ -131,7 +131,7 @@ CL_DEFUN Integer_sp cl__get_universal_time() { time(¤t_time); Integer_sp offset = Integer_O::create(static_cast(2208988800)); Integer_sp unix_time = Integer_O::create(static_cast(current_time)); - Integer_sp utime = gc::As_unsafe(contagion_add(unix_time, offset)); + Integer_sp utime = gc::As_unsafe(unix_time + offset); return utime; } @@ -222,43 +222,47 @@ SYMBOL_EXPORT_SC_(ExtPkg, longFloatNegativeInfinity); SYMBOL_EXPORT_SC_(ClPkg, pi); void exposeCando_Numerics() { - cl::_sym_mostPositiveSingleFloat->defconstant(clasp_make_single_float(std::numeric_limits::max())); - cl::_sym_mostNegativeSingleFloat->defconstant(clasp_make_single_float(-std::numeric_limits::max())); - cl::_sym_leastPositiveSingleFloat->defconstant(clasp_make_single_float(std::numeric_limits::denorm_min())); - cl::_sym_leastNegativeSingleFloat->defconstant(clasp_make_single_float(-std::numeric_limits::denorm_min())); - cl::_sym_mostPositiveShortFloat->defconstant(clasp_make_single_float(std::numeric_limits::max())); - cl::_sym_mostNegativeShortFloat->defconstant(clasp_make_single_float(-std::numeric_limits::max())); - cl::_sym_leastPositiveShortFloat->defconstant(clasp_make_single_float(std::numeric_limits::denorm_min())); - cl::_sym_leastNegativeShortFloat->defconstant(clasp_make_single_float(-std::numeric_limits::denorm_min())); - cl::_sym_mostPositiveDoubleFloat->defconstant(DoubleFloat_O::create(std::numeric_limits::max())); - cl::_sym_mostNegativeDoubleFloat->defconstant(DoubleFloat_O::create(-std::numeric_limits::max())); - cl::_sym_leastPositiveDoubleFloat->defconstant(DoubleFloat_O::create(std::numeric_limits::denorm_min())); - cl::_sym_leastNegativeDoubleFloat->defconstant(DoubleFloat_O::create(-std::numeric_limits::denorm_min())); - cl::_sym_mostPositiveLongFloat->defconstant(DoubleFloat_O::create(std::numeric_limits::max())); - cl::_sym_mostNegativeLongFloat->defconstant(DoubleFloat_O::create(-std::numeric_limits::max())); - cl::_sym_leastPositiveLongFloat->defconstant(DoubleFloat_O::create(std::numeric_limits::denorm_min())); - cl::_sym_leastNegativeLongFloat->defconstant(DoubleFloat_O::create(-std::numeric_limits::denorm_min())); + cl::_sym_mostPositiveShortFloat->defconstant(clasp_make_single_float(std::numeric_limits::max())); + cl::_sym_mostNegativeShortFloat->defconstant(clasp_make_single_float(-std::numeric_limits::max())); + cl::_sym_leastPositiveShortFloat->defconstant(clasp_make_single_float(std::numeric_limits::denorm_min())); + cl::_sym_leastNegativeShortFloat->defconstant(clasp_make_single_float(-std::numeric_limits::denorm_min())); + cl::_sym_leastNegativeNormalizedShortFloat->defconstant(clasp_make_single_float(-std::numeric_limits::min())); + cl::_sym_leastPositiveNormalizedShortFloat->defconstant(clasp_make_single_float(std::numeric_limits::min())); + ext::_sym_shortFloatPositiveInfinity->defconstant(clasp_make_single_float(std::numeric_limits::infinity())); + ext::_sym_shortFloatNegativeInfinity->defconstant(clasp_make_single_float(-std::numeric_limits::infinity())); - cl::_sym_leastNegativeNormalizedSingleFloat->defconstant(clasp_make_single_float(-std::numeric_limits::min())); - cl::_sym_leastNegativeNormalizedShortFloat->defconstant(clasp_make_single_float(-std::numeric_limits::min())); - cl::_sym_leastNegativeNormalizedDoubleFloat->defconstant(DoubleFloat_O::create(-std::numeric_limits::min())); - cl::_sym_leastNegativeNormalizedLongFloat->defconstant(LongFloat_O::create(-std::numeric_limits::min())); - // the following must be positive, not negative, fixes #434 - cl::_sym_leastPositiveNormalizedSingleFloat->defconstant(clasp_make_single_float(std::numeric_limits::min())); - cl::_sym_leastPositiveNormalizedShortFloat->defconstant(clasp_make_single_float(std::numeric_limits::min())); - cl::_sym_leastPositiveNormalizedDoubleFloat->defconstant(DoubleFloat_O::create(std::numeric_limits::min())); - cl::_sym_leastPositiveNormalizedLongFloat->defconstant(LongFloat_O::create(std::numeric_limits::min())); + cl::_sym_mostPositiveSingleFloat->defconstant(clasp_make_single_float(std::numeric_limits::max())); + cl::_sym_mostNegativeSingleFloat->defconstant(clasp_make_single_float(-std::numeric_limits::max())); + cl::_sym_leastPositiveSingleFloat->defconstant(clasp_make_single_float(std::numeric_limits::denorm_min())); + cl::_sym_leastNegativeSingleFloat->defconstant(clasp_make_single_float(-std::numeric_limits::denorm_min())); + cl::_sym_leastNegativeNormalizedSingleFloat->defconstant(clasp_make_single_float(-std::numeric_limits::min())); + cl::_sym_leastPositiveNormalizedSingleFloat->defconstant(clasp_make_single_float(std::numeric_limits::min())); + ext::_sym_singleFloatPositiveInfinity->defconstant(clasp_make_single_float(std::numeric_limits::infinity())); + ext::_sym_singleFloatNegativeInfinity->defconstant(clasp_make_single_float(-std::numeric_limits::infinity())); - cl::_sym_pi->defconstant(DoubleFloat_O::create(3.14159265358979323846264338)); - // extensions - ext::_sym_singleFloatPositiveInfinity->defconstant(clasp_make_single_float(std::numeric_limits::infinity())); - ext::_sym_singleFloatNegativeInfinity->defconstant(clasp_make_single_float(-std::numeric_limits::infinity())); - ext::_sym_shortFloatPositiveInfinity->defconstant(clasp_make_single_float(std::numeric_limits::infinity())); - ext::_sym_shortFloatNegativeInfinity->defconstant(clasp_make_single_float(-std::numeric_limits::infinity())); - ext::_sym_doubleFloatPositiveInfinity->defconstant(DoubleFloat_O::create(std::numeric_limits::infinity())); - ext::_sym_doubleFloatNegativeInfinity->defconstant(DoubleFloat_O::create(-std::numeric_limits::infinity())); - ext::_sym_longFloatPositiveInfinity->defconstant(DoubleFloat_O::create(std::numeric_limits::infinity())); - ext::_sym_longFloatNegativeInfinity->defconstant(DoubleFloat_O::create(-std::numeric_limits::infinity())); + cl::_sym_mostPositiveDoubleFloat->defconstant(DoubleFloat_O::create(std::numeric_limits::max())); + cl::_sym_mostNegativeDoubleFloat->defconstant(DoubleFloat_O::create(-std::numeric_limits::max())); + cl::_sym_leastPositiveDoubleFloat->defconstant(DoubleFloat_O::create(std::numeric_limits::denorm_min())); + cl::_sym_leastNegativeDoubleFloat->defconstant(DoubleFloat_O::create(-std::numeric_limits::denorm_min())); + cl::_sym_leastNegativeNormalizedDoubleFloat->defconstant(DoubleFloat_O::create(-std::numeric_limits::min())); + cl::_sym_leastPositiveNormalizedDoubleFloat->defconstant(DoubleFloat_O::create(std::numeric_limits::min())); + ext::_sym_doubleFloatPositiveInfinity->defconstant(DoubleFloat_O::create(std::numeric_limits::infinity())); + ext::_sym_doubleFloatNegativeInfinity->defconstant(DoubleFloat_O::create(-std::numeric_limits::infinity())); + + cl::_sym_mostPositiveLongFloat->defconstant(LongFloat_O::create(std::numeric_limits::max())); + cl::_sym_mostNegativeLongFloat->defconstant(LongFloat_O::create(-std::numeric_limits::max())); + cl::_sym_leastPositiveLongFloat->defconstant(LongFloat_O::create(std::numeric_limits::denorm_min())); + cl::_sym_leastNegativeLongFloat->defconstant(LongFloat_O::create(-std::numeric_limits::denorm_min())); + cl::_sym_leastNegativeNormalizedLongFloat->defconstant(LongFloat_O::create(-std::numeric_limits::min())); + cl::_sym_leastPositiveNormalizedLongFloat->defconstant(LongFloat_O::create(std::numeric_limits::min())); + ext::_sym_longFloatPositiveInfinity->defconstant(LongFloat_O::create(std::numeric_limits::infinity())); + ext::_sym_longFloatNegativeInfinity->defconstant(LongFloat_O::create(-std::numeric_limits::infinity())); + +#if defined(_TARGET_OS_DARWIN) && defined(CLASP_LONG_FLOAT) + cl::_sym_pi->defconstant(LongFloat_O::create(3.141592653589793238462643383279502884l)); +#else + cl::_sym_pi->defconstant(LongFloat_O::create(std::numbers::pi_v)); +#endif } }; // namespace core diff --git a/src/core/pathname.cc b/src/core/pathname.cc index dc43fc8e55..2f2a1e06b1 100644 --- a/src/core/pathname.cc +++ b/src/core/pathname.cc @@ -753,7 +753,7 @@ Pathname_sp clasp_parseNamestring(T_sp s, size_t start, size_t end, size_t* ep, T_sp tversion = version_mv; MultipleValues& mvn = core::lisp_multipleValues(); Fixnum_sp parsed_length = gc::As(mvn.valueGet(1, version_mv.number_of_values())); - if (unbox_fixnum(parsed_length) == cl__length(aux) && cl__integerp(tversion) && clasp_plusp(gc::As(tversion))) { + if (unbox_fixnum(parsed_length) == cl__length(aux) && cl__integerp(tversion) && Real_O::plusp(gc::As(tversion))) { version = gc::As(tversion); } else if (cl__string_equal(aux, kw::_sym_newest).notnilp()) { version = kw::_sym_newest; diff --git a/src/core/primitives.cc b/src/core/primitives.cc index 4e92f3f0dc..0f240631ad 100644 --- a/src/core/primitives.cc +++ b/src/core/primitives.cc @@ -769,7 +769,7 @@ CL_DEFUN T_sp cl__special_operator_p(Symbol_sp sym) { CL_DEFUN Integer_sp core__ash_left(Integer_sp integer, Integer_sp count) { if (count.fixnump()) return clasp_shift_left(integer, count.unsafe_fixnum()); - else if (clasp_zerop(integer)) + else if (Number_O::zerop(integer)) return integer; else SIMPLE_ERROR("ash for bignum count not implemented"); @@ -779,7 +779,7 @@ CL_DEFUN Integer_sp core__ash_right(Integer_sp integer, Integer_sp count) { if (count.fixnump()) return clasp_shift_right(integer, count.unsafe_fixnum()); // bignum zero is impossible, so: all digits gone. - else if (clasp_minusp(integer)) + else if (Real_O::minusp(integer)) return clasp_make_fixnum(-1); else return clasp_make_fixnum(0); @@ -801,15 +801,15 @@ CL_DEFUN Integer_sp cl__ash(Integer_sp integer, Integer_sp count) { // count is bignum // We don't have integers with more than most-positive-fixnum digits, // so this operation is now pretty trivial. - if (clasp_plusp(count)) { - if (clasp_zerop(integer)) + if (Real_O::plusp(count)) { + if (Number_O::zerop(integer)) return integer; // result will not fit in memory, giveup (FIXME: storage-condition?) else SIMPLE_ERROR("ash for bignum count not implemented"); - } else if (clasp_minusp(count)) { + } else if (Real_O::minusp(count)) { // Count is a negative bignum, so all digits are gone. - if (clasp_minusp(integer)) + if (Real_O::minusp(integer)) return clasp_make_fixnum(-1); else return clasp_make_fixnum(0); @@ -1583,7 +1583,7 @@ CL_DEFUN Symbol_sp cl__gensym(T_sp x) { StringPushString(ss, sx); core__integer_to_string(ss, gc::As(cl::_sym_STARgensym_counterSTAR->symbolValue()), clasp_make_fixnum(10)); // If and only if no explicit suffix is supplied, *gensym-counter* is incremented after it is used. - if (clasp_minusp(counter)) + if (Real_O::minusp(counter)) TYPE_ERROR(counter, cl::_sym_UnsignedByte); if (counter.fixnump()) { Fixnum gensymCounter = counter.unsafe_fixnum() + 1; @@ -1600,7 +1600,7 @@ CL_DEFUN Symbol_sp cl__gensym(T_sp x) { } return Symbol_O::create(ss->asMinimalSimpleString()); } - if ((x.fixnump() || gc::IsA(x)) && (!(clasp_minusp(gc::As_unsafe(x))))) { + if ((x.fixnump() || gc::IsA(x)) && (!(Real_O::minusp(gc::As_unsafe(x))))) { SafeBufferStr8Ns ss; ss.string()->vectorPushExtend('G'); core__integer_to_string(ss.string(), gc::As_unsafe(x), clasp_make_fixnum(10)); @@ -1623,12 +1623,16 @@ CL_DEFUN Symbol_mv core__type_to_symbol(T_sp x) { return (Values(cl::_sym_character)); else if (x.single_floatp()) return (Values(cl::_sym_single_float)); +#ifdef CLASP_SHORT_FLOAT + else if (x.short_floatp()) + return (Values(cl::_sym_short_float)); +#endif else if (x.consp()) return (Values(cl::_sym_list)); else if (x.generalp()) { General_sp gx(x.unsafe_general()); if (gc::IsA(gx)) - return (Values(cl::_sym_DoubleFloat_O)); + return (Values(cl::_sym_double_float)); else if (gc::IsA(gx)) return (Values(cl::_sym_Symbol_O)); else if (gx.nilp()) @@ -1639,7 +1643,7 @@ CL_DEFUN Symbol_mv core__type_to_symbol(T_sp x) { return (Values(cl::_sym_Ratio_O)); #ifdef CLASP_LONG_FLOAT else if (gc::IsA(gx)) - return (Values(cl::_sym_LongFloat_O)); + return (Values(cl::_sym_long_float)); #endif else if (gc::IsA(gx)) return (Values(cl::_sym_Complex_O)); diff --git a/src/core/random.cc b/src/core/random.cc index 6051dce8da..0223254f81 100644 --- a/src/core/random.cc +++ b/src/core/random.cc @@ -95,19 +95,40 @@ CL_DEFUN T_sp cl__random(Number_sp olimit, RandomState_sp random_state) { BIGNUM_NORMALIZE(len, res); return cl__mod(bignum_result(len, res), gbn); } else if (DoubleFloat_sp df = olimit.asOrNull()) { - if (df->get() == DBL_TRUE_MIN) { + if (df->get() == std::numeric_limits::denorm_min()) { return DoubleFloat_O::create(0.0); } else if (df->get() > 0.0) { - std::uniform_real_distribution<> range(0.0, df->get()); + std::uniform_real_distribution range(0.0, df->get()); return DoubleFloat_O::create(range(random_state->_Producer._value)); } else TYPE_ERROR_cl_random(olimit); +#ifdef CLASP_SHORT_FLOAT + } else if (olimit.short_floatp()) { + short_float_t flimit = olimit.unsafe_short_float(); + if (flimit == std::numeric_limits::denorm_min()) { + return ShortFloat_O::create(short_float_t{0}); + } else if (flimit > short_float_t{0}) { + std::uniform_real_distribution range(short_float_t{0}, flimit); + return ShortFloat_O::create(range(random_state->_Producer._value)); + } else + TYPE_ERROR_cl_random(olimit); +#endif +#ifdef CLASP_LONG_FLOAT + } else if (LongFloat_sp lf = olimit.asOrNull()) { + if (lf->get() == std::numeric_limits::denorm_min()) { + return LongFloat_O::create(long_float_t{0.0}); + } else if (lf->get() > long_float_t{0.0}) { + std::uniform_real_distribution range(long_float_t{0.0}, lf->get()); + return LongFloat_O::create(range(random_state->_Producer._value)); + } else + TYPE_ERROR_cl_random(olimit); +#endif } else if (olimit.single_floatp()) { float flimit = olimit.unsafe_single_float(); - if (flimit == FLT_TRUE_MIN) { + if (flimit == std::numeric_limits::denorm_min()) { return clasp_make_single_float(0.0f); } else if (flimit > 0.0f) { - std::uniform_real_distribution<> range(0.0, flimit); + std::uniform_real_distribution range(0.0, flimit); return clasp_make_single_float(range(random_state->_Producer._value)); } else TYPE_ERROR_cl_random(olimit); diff --git a/src/core/sequence.cc b/src/core/sequence.cc index 74d6feaea2..7ce230c4db 100644 --- a/src/core/sequence.cc +++ b/src/core/sequence.cc @@ -204,14 +204,14 @@ size_t_pair sequenceKeywordStartEnd(Symbol_sp fn_name, T_sp sequence, Fixnum_sp size_t_pair p; size_t l; p.length = l = cl__length(sequence); - unlikely_if(!core__fixnump(start) || clasp_minusp(start)) { + unlikely_if(!core__fixnump(start) || Real_O::minusp(start)) { ERROR_WRONG_TYPE_KEY_ARG(fn_name, kw::_sym_start, start, cl::_sym_UnsignedByte); } p.start = unbox_fixnum(start); if (end.nilp()) { p.end = l; } else { - unlikely_if(!core__fixnump(end) || clasp_minusp(gc::As(end))) { + unlikely_if(!core__fixnump(end) || Real_O::minusp(gc::As(end))) { ERROR_WRONG_TYPE_KEY_ARG(fn_name, kw::_sym_end, end, Cons_O::createList(cl::_sym_or, cl::_sym_null, cl::_sym_UnsignedByte)); } p.end = unbox_fixnum(gc::As(end)); @@ -242,7 +242,7 @@ size_t_pair sequenceStartEnd(Symbol_sp fn_name, size_t vector_length, size_t sta if (end.nilp()) { p.end = l; } else { - unlikely_if(!core__fixnump(end) || clasp_minusp(gc::As(end))) { + unlikely_if(!core__fixnump(end) || Real_O::minusp(gc::As(end))) { FUNCTION_WRONG_TYPE_ARG(fn_name, end, Cons_O::createList(cl::_sym_or, cl::_sym_null, cl::_sym_UnsignedByte)); } p.end = unbox_fixnum(gc::As(end)); diff --git a/src/core/unixfsys.cc b/src/core/unixfsys.cc index 624c632c84..050a4c1edf 100644 --- a/src/core/unixfsys.cc +++ b/src/core/unixfsys.cc @@ -1109,19 +1109,18 @@ CL_LAMBDA(pathspec); CL_DECLARE(); CL_DOCSTRING(R"dx(file_write_date)dx"); DOCGROUP(clasp); -CL_DEFUN Number_sp cl__file_write_date(T_sp pathspec) { - Number_sp time; +CL_DEFUN T_sp cl__file_write_date(T_sp pathspec) { + T_sp time; if (pathspec.nilp()) SIMPLE_ERROR("{} was about to pass nil to pathname", __FUNCTION__); Pathname_sp pathname = cl__pathname(pathspec); String_sp filename = coerce_to_posix_filename(pathname); struct stat filestatus; - time = nil(); + time = nil(); if (safe_stat((char*)filename->get_path_string().c_str(), &filestatus) >= 0) { - Number_sp accJan1st1970UT(Integer_O::create((gc::Fixnum)(24 * 60 * 60))); - accJan1st1970UT = contagion_mul(accJan1st1970UT, Integer_O::create((gc::Fixnum)(17 + 365 * 70))); - time = Integer_O::create((gc::Fixnum)filestatus.st_mtime); - time = contagion_add(time, accJan1st1970UT); + Integer_sp accJan1st1970UT = Integer_O::create((gc::Fixnum)(24 * 60 * 60)); + accJan1st1970UT = accJan1st1970UT * Integer_O::create((gc::Fixnum)(17 + 365 * 70)); + time = Integer_O::create((gc::Fixnum)filestatus.st_mtime) + accJan1st1970UT; } return time; } diff --git a/src/gctools/gc_boot.cc b/src/gctools/gc_boot.cc index 6593dcc6bb..a202659ea6 100644 --- a/src/gctools/gc_boot.cc +++ b/src/gctools/gc_boot.cc @@ -59,6 +59,7 @@ void dump_data_types(std::ostream& fout, const std::string& indent) { DTNAME(CONSTANT_ARRAY_OFFSET, "constant_array", sizeof(void*)); DTNAME(ctype_double, "double", sizeof(double)); DTNAME(ctype_float, "float", sizeof(float)); + DTNAME(ctype_long_double, "long double", sizeof(long double)); DTNAME(ctype_int, "int", sizeof(int)); DTNAME(ctype_short, "short", sizeof(short)); DTNAME(ctype_unsigned_char, "unsigned_char", sizeof(unsigned char)); diff --git a/src/gctools/gc_interface.cc b/src/gctools/gc_interface.cc index 69066210a3..c88075984a 100644 --- a/src/gctools/gc_interface.cc +++ b/src/gctools/gc_interface.cc @@ -902,7 +902,9 @@ void dumpBoehmLayoutTables(std::ostream& fout) { Init_class_kind(core::MDArray_byte16_t_O); Init_class_kind(core::SimpleMDArray_O); Init_class_kind(core::SimpleMDArray_int8_t_O); + Init_class_kind(core::SimpleMDArray_short_float_O); Init_class_kind(core::SimpleMDArray_double_O); + Init_class_kind(core::SimpleMDArray_long_float_O); Init_class_kind(core::SimpleMDArray_byte32_t_O); Init_class_kind(core::SimpleMDArrayT_O); Init_class_kind(core::SimpleMDArray_int2_t_O); @@ -923,8 +925,12 @@ void dumpBoehmLayoutTables(std::ostream& fout) { Init_class_kind(core::SimpleMDArray_int64_t_O); Init_class_kind(core::MDArray_int4_t_O); Init_class_kind(core::MDArray_double_O); + Init_class_kind(core::MDArray_short_float_O); + Init_class_kind(core::MDArray_long_float_O); Init_class_kind(core::ComplexVector_O); + Init_class_kind(core::ComplexVector_short_float_O); Init_class_kind(core::ComplexVector_double_O); + Init_class_kind(core::ComplexVector_long_float_O); Init_class_kind(core::ComplexVector_int8_t_O); Init_class_kind(core::ComplexVector_byte64_t_O); Init_class_kind(core::ComplexVector_T_O); @@ -953,7 +959,9 @@ void dumpBoehmLayoutTables(std::ostream& fout) { Init_class_kind(core::SimpleVector_int4_t_O); Init_class_kind(core::SimpleVector_byte32_t_O); Init_class_kind(core::SimpleVector_size_t_O); + Init_class_kind(core::SimpleVector_short_float_O); Init_class_kind(core::SimpleVector_double_O); + Init_class_kind(core::SimpleVector_long_float_O); Init_class_kind(core::SimpleVector_byte64_t_O); Init_class_kind(core::SimpleVector_int2_t_O); Init_class_kind(core::SimpleVector_int64_t_O); diff --git a/src/gctools/mpsGarbageCollection.cc b/src/gctools/mpsGarbageCollection.cc index 0c964ad78d..758ed65366 100644 --- a/src/gctools/mpsGarbageCollection.cc +++ b/src/gctools/mpsGarbageCollection.cc @@ -758,8 +758,8 @@ size_t processMpsMessages(size_t& finalizations) { #if 0 // printf("%s:%d Leaving processMpsMessages\n",__FILE__,__LINE__); core::Number_sp endTime = core::cl__get_internal_run_time().as(); - core::Number_sp deltaTime = core::contagion_mul(core::contagion_sub(endTime,startTime),core::make_fixnum(1000)); - core::Number_sp deltaSeconds = core::contagion_div(deltaTime,cl::_sym_internalTimeUnitsPerSecond->symbolValue().as()); + core::Number_sp deltaTime = (endTime - startTime) * core::make_fixnum(1000); + core::Number_sp deltaSeconds = deltaTime / cl::_sym_internalTimeUnitsPerSecond->symbolValue().as(); printf("%s:%d [processMpsMessages %s millisecs for %d finalization/ %d gc-start/ %d gc messages]\n", __FILE__, __LINE__, _rep_(deltaSeconds).c_str(), mFinalize, mGcStart, mGc ); fflush(stdout); #endif diff --git a/src/koga/config-header.lisp b/src/koga/config-header.lisp index bf8ca7496b..5f17a78f53 100644 --- a/src/koga/config-header.lisp +++ b/src/koga/config-header.lisp @@ -44,6 +44,8 @@ "INCLUDED_FROM_CLASP" t "INHERITED_FROM_SRC" t "NDEBUG" t + "USE_SHORT_FLOAT" (use-short-float configuration) + "USE_LONG_FLOAT" (use-long-float configuration) "BUILD_EXTENSION" (and (extensions configuration) t) "DEFAULT_STARTUP_TYPE" (if (extensions configuration) :|cloExtensionImage| :|cloBaseImage|) "CLASP_EXTENSIONS" (and (extensions configuration) t) diff --git a/src/koga/configure.lisp b/src/koga/configure.lisp index e9d75f8dff..ffcf38a64d 100644 --- a/src/koga/configure.lisp +++ b/src/koga/configure.lisp @@ -613,6 +613,16 @@ is not compatible with snapshots.") :initarg :dependency-file :initform nil :documentation "Path to dependency-file") + (use-short-float :accessor use-short-float + :initarg :use-short-float + :initform nil + :type boolean + :documentation "Enable short-float") + (use-long-float :accessor use-long-float + :initarg :use-long-float + :initform t + :type boolean + :documentation "Enable long-float") (units :accessor units :initform '(:git :describe :cpu-count #+darwin :xcode :base :default-target :pkg-config :clang :llvm :ar :cc :cxx :dis :mpi :nm :etags :ctags :objcopy :jupyter diff --git a/src/koga/units.lisp b/src/koga/units.lisp index e0383a8c36..f3880173b7 100644 --- a/src/koga/units.lisp +++ b/src/koga/units.lisp @@ -205,10 +205,8 @@ (append-cflags configuration "-O3 -g -fPIC" :type :cflags :debug nil) (append-cflags configuration "-O0 -g" :type :cxxflags :debug t) (append-cflags configuration "-O0 -g" :type :cflags :debug t) - (append-cflags configuration (if (broken-stdlib configuration) - "-std=c++17 -Wno-c++20-extensions" - "-std=c++20") - :type :cxxflags) + (append-cflags configuration "-fconstexpr-steps=10000000" :type :cxxflags) + (append-cflags configuration "-std=gnu++20" :type :cxxflags) #+darwin (append-cflags configuration "-stdlib=libc++" :type :cxxflags) #+darwin (append-cflags configuration "-I/usr/local/include") #+linux (append-cflags configuration "-fno-omit-frame-pointer -mno-omit-leaf-frame-pointer -fno-stack-protector -stdlib=libstdc++" diff --git a/src/lisp/kernel/cleavir/type.lisp b/src/lisp/kernel/cleavir/type.lisp index 90e86624c3..ac17658e60 100644 --- a/src/lisp/kernel/cleavir/type.lisp +++ b/src/lisp/kernel/cleavir/type.lisp @@ -363,10 +363,16 @@ (derive-type-predicate object 'rational *clasp-system*)) (define-deriver floatp (object) (derive-type-predicate object 'float *clasp-system*)) +#+short-float +(define-deriver core:short-float-p (object) + (derive-type-predicate object 'short-float *clasp-system*)) (define-deriver core:single-float-p (object) (derive-type-predicate object 'single-float *clasp-system*)) (define-deriver core:double-float-p (object) (derive-type-predicate object 'double-float *clasp-system*)) +#+long-float +(define-deriver core:long-float-p (object) + (derive-type-predicate object 'long-float *clasp-system*)) (define-deriver integerp (object) (derive-type-predicate object 'integer *clasp-system*)) (define-deriver core:fixnump (object) @@ -393,7 +399,9 @@ (t ty2))) ((short-float) (case ty2 - ((integer ratio rational short-float) 'single-float) + ((integer ratio rational short-float) + #+short-float 'short-float + #-short-float 'single-float) (t ty2))) ((single-float) (case ty2 @@ -405,7 +413,9 @@ (t ty2))) ((long-float) (case ty2 - ((integer ratio rational short-float single-float long-float) 'double-float) + ((integer ratio rational short-float single-float double-float) + #+long-float 'long-float + #-long-float 'double-float) (t ty2))) ((float) (case ty2 @@ -769,7 +779,7 @@ (flet ((%coerce (num) (ecase kind ((integer rational) (rational num)) - ((single-float double-float float) (coerce num kind)) + ((short-float single-float double-float long-float float) (coerce num kind)) ((real) num)))) (cond ((null bound) '*) ((consp bound) (list (%coerce (car bound)))) @@ -846,6 +856,7 @@ ((single-float) (if (eq (ctype:range-kind y sys) 'double-float) 'double-float 'single-float)) ((double-float) 'double-float) + ((long-float) 'long-float) ((float) 'float) ((integer) (let ((ykind (ctype:range-kind y sys))) @@ -940,7 +951,8 @@ ((integer rational single-float) (ctype:range 'single-float 0f0 (float pi 0f0) sys)) ((double-float) (ctype:range 'double-float 0d0 pi sys)) - ((float real) (ctype:range 'float 0d0 pi sys))) + ((long-float) (ctype:range 'long-float 0l0 pi sys)) + ((float real) (ctype:range 'float 0l0 pi sys))) (env:parse-type-specifier 'number nil sys))) (env:parse-type-specifier 'number nil sys)) sys))) @@ -966,6 +978,7 @@ (case kind ((single-float) 0f0) ((double-float float) 0d0) + ((long-float) 0l0) (t 0))) ((or (not high) (< low (abs high))) (if lxp (list low) low)) @@ -1011,6 +1024,8 @@ (derive-to-float num 'single-float sys)) ((ctype:subtypep proto (ctype:range 'double-float '* '* sys) sys) (derive-to-float num 'double-float sys)) + ((ctype:subtypep proto (ctype:range 'long-float '* '* sys) sys) + (derive-to-float num 'long-float sys)) (t floatt)))) (ctype:single-value (cond ((eq protop t) (float2)) ; definitely supplied @@ -1024,6 +1039,10 @@ (define-deriver core:to-double-float (num) (let ((sys *clasp-system*)) (ctype:single-value (derive-to-float num 'double-float sys) sys))) +#+long-float +(define-deriver core:to-long-float (num) + (let ((sys *clasp-system*)) + (ctype:single-value (derive-to-float num 'long-float sys) sys))) (define-deriver random (max &optional random-state) (declare (ignore random-state)) @@ -1043,6 +1062,8 @@ (ctype:range 'single-float 0f0 '* sys)) ((subtypep max (ctype:range 'double-float 0d0 '* sys)) (ctype:range 'double-float 0d0 '* sys)) + ((subtypep max (ctype:range 'long-float 0l0 '* sys)) + (ctype:range 'long-float 0l0 '* sys)) (t (env:parse-type-specifier '(real 0) nil sys))) sys))) @@ -1398,6 +1419,10 @@ (def core:make-simple-vector-character character) (def core:make-simple-vector-single-float single-float) (def core:make-simple-vector-double-float double-float) + #+short-float + (def core:make-simple-vector-short-float short-float) + #+long-float + (def core:make-simple-vector-long-float long-float) (def core:make-simple-vector-int2 ext:integer2) (def core:make-simple-vector-byte2 ext:byte2) (def core:make-simple-vector-int4 ext:integer4) diff --git a/src/lisp/kernel/cmp/bytecode-machines.lisp b/src/lisp/kernel/cmp/bytecode-machines.lisp index 24706cd042..cdae7ed3dd 100644 --- a/src/lisp/kernel/cmp/bytecode-machines.lisp +++ b/src/lisp/kernel/cmp/bytecode-machines.lisp @@ -261,7 +261,108 @@ (in-package :cmpref) +(defvar +reserved-c++-keywords+ + '("alignas" + "alignof" + "and" + "and_eq" + "asm" + "atomic_cancel" + "atomic_commit" + "atomic_noexcept" + "auto" + "bitand" + "bitor" + "bool" + "break" + "case" + "catch" + "char" + "char8_t" + "char16_t" + "char32_t" + "class" + "compl" + "concept" + "const" + "consteval" + "constexpr" + "constinit" + "const_cast" + "continue" + "co_await" + "co_return" + "co_yield" + "decltype" + "default" + "delete" + "do" + "double" + "dynamic_cast" + "else" + "enum" + "explicit" + "export" + "extern" + "false" + "float" + "for" + "friend" + "goto" + "if" + "inline" + "int" + "long" + "mutable" + "namespace" + "new" + "noexcept" + "not" + "not_eq" + "nullptr" + "operator" + "or" + "or_eq" + "private" + "protected" + "public" + "reflexpr" + "register" + "reinterpret_cast" + "requires" + "return" + "short" + "signed" + "sizeof" + "static" + "static_assert" + "static_cast" + "struct" + "switch" + "synchronized" + "template" + "this" + "thread_local" + "throw" + "true" + "try" + "typedef" + "typeid" + "typename" + "union" + "unsigned" + "using" + "virtual" + "void" + "volatile" + "wchar_t" + "while" + "xor" + "xor_eq")) + (defun c++ify (name) + (when (member name +reserved-c++-keywords+ :test #'equalp) + (setf name (concatenate 'string "_" name))) (flet ((submatch (substr remain) (let ((sublen (length substr))) (and (>= (length remain) sublen) (string= substr remain :start2 0 :end2 sublen))))) @@ -292,10 +393,10 @@ (dolist (item *full-codes*) (let* ((name (first item)) (opcode (second item)) - (sym-name (format nil "vm_~a" (c++ify name)))) + (sym-name (c++ify name))) (push (format nil "~a=~a" sym-name opcode) rev-codes))) (nreverse rev-codes)))) - (format fout "enum vm_codes {~%~{ ~a~^,~^~%~} };~%" enums)) + (format fout "enum class vm_code : uint8_t {~%~{ ~a~^,~^~%~} };~%" enums)) (terpri fout) (write-line "#endif // VM_CODES" fout)) @@ -313,17 +414,20 @@ (set-ltv-info :size_t "size_t" "size_t") (set-ltv-info :t* "T_O*" "object" t) (set-ltv-info :i8* "string" "string") + (set-ltv-info :short-float "short_float_t" "binary16") (set-ltv-info :single-float "float" "float") (set-ltv-info :double-float "double" "double") + (set-ltv-info :binary80 "long_float_t" "binary80") + (set-ltv-info :binary128 "long_float_t" "binary128") (set-ltv-info :uintptr_t "uintptr_t" "size_t") (set-ltv-info :bignum "T_O*" "bignum") (set-ltv-info :unknown "UNKNOWN" "UNKNOWN") ) (defun build-one-ltv-function (op &optional (stream *standard-output*)) - (destructuring-bind (unwindsp name arg-types &key varargs) + (destructuring-bind (code unwindsp name arg-types &key varargs) op - (declare (ignore unwindsp)) + (declare (ignore code unwindsp)) (format stream "void parse_~a(gctools::GCRootsInModule* roots, char*& bytecode, char* byteend, bool log) {~%" name) (format stream " if (log) printf(\"%s:%d:%s parse_~a\\n\", __FILE__, __LINE__, __FUNCTION__);~%" name) (let* ((arg-index 0) @@ -371,18 +475,30 @@ (defun build-ltv-switch (primitives &optional (stream *standard-output*)) (format stream "#ifdef DEFINE_LTV_SWITCH~%") - (let ((code 65)) - (dolist (prim primitives) - (let ((func-name (second prim))) - (format stream " case ~a: parse_~a(roots,bytecode,byteend,log);~%" code func-name) - (format stream " break;~%") - (incf code)))) + (dolist (prim primitives) + (format stream " case ~a:~% parse_~a(roots, bytecode, byteend, log);~% break;~%" + (first prim) (third prim))) (format stream "#endif // DEFINE_LTV_SWITCH~%")) (defun build-ltv-machine (&optional (stream *standard-output*)) (build-ltv-functions *startup-primitives-as-list* stream) (build-ltv-switch *startup-primitives-as-list* stream)) +(defun build-bytecode-ltv-ops (&optional (stream *standard-output*)) + (format stream "~%#ifdef DEFINE_BYTECODE_LTV_OPS~%enum class bytecode_ltv : uint8_t {~%") + (dolist (op +bytecode-ltv-ops+) + (format stream " ~(~a~) = ~a,~%" + (c++ify (symbol-name (first op))) (second op))) + (format stream "};~%enum class bytecode_uaet : uint8_t {~%") + (loop for (key code) on +uaet-codes+ by #'cddr + do (format stream " ~(~a~) = ~a,~%" + (c++ify (symbol-name key)) code)) + (format stream "};~%enum class bytecode_debug_info : uint8_t {~%") + (loop for (key code) on +debug-info-ops+ by #'cddr + do (format stream " ~(~a~) = ~a,~%" + (c++ify (symbol-name key)) code)) + (format stream "};~%#endif~%")) + ;;; entry point (defun generate-virtual-machine-header (fout) @@ -391,4 +507,5 @@ (clos:dump-gf-bytecode-virtual-machine fout) (clos:dump-gf-bytecode-virtual-machine-macro-names fout) (clos:dump-python-gf-bytecode-virtual-machine fout) - (build-ltv-machine fout)) + (build-ltv-machine fout) + (build-bytecode-ltv-ops fout)) diff --git a/src/lisp/kernel/cmp/cmpintrinsics.lisp b/src/lisp/kernel/cmp/cmpintrinsics.lisp index 6355232a10..60175ebcf8 100644 --- a/src/lisp/kernel/cmp/cmpintrinsics.lisp +++ b/src/lisp/kernel/cmp/cmpintrinsics.lisp @@ -186,9 +186,14 @@ names to offsets." (define-symbol-macro %word% #+64-bit %i64% #+32-bit %i32%) (define-symbol-macro %uint% %i32%) ; FIXME: export from C++ probably +#+short-float/binary16 +(define-symbol-macro %long-float% (llvm-sys:type-get-half-ty (thread-local-llvm-context))) (define-symbol-macro %float% (llvm-sys:type-get-float-ty (thread-local-llvm-context))) (define-symbol-macro %double% (llvm-sys:type-get-double-ty (thread-local-llvm-context))) -#+long-float (define-symbol-macro %long-float% (llvm-sys:type-get-long-float-ty (thread-local-llvm-context))) +#+long-float/binary80 +(define-symbol-macro %long-float% (llvm-sys:type-get-x86-fp80-ty (thread-local-llvm-context))) +#+long-float/binary128 +(define-symbol-macro %long-float% (llvm-sys:type-get-fp128-ty (thread-local-llvm-context))) (define-symbol-macro %size_t% #+64-bit %i64% #+32-bit %i32%) diff --git a/src/lisp/kernel/cmp/cmpliteral.lisp b/src/lisp/kernel/cmp/cmpliteral.lisp index ec2a94b36a..a104df4291 100644 --- a/src/lisp/kernel/cmp/cmpliteral.lisp +++ b/src/lisp/kernel/cmp/cmpliteral.lisp @@ -26,8 +26,12 @@ (defstruct (literal-node-closure (:type vector) (:include literal-dnode) :named) function-index function entry-point-ref) (defstruct (function-datum (:type vector) :named) index) +#+short-float +(defstruct (short-float-datum (:type vector) :named) value) (defstruct (single-float-datum (:type vector) :named) value) (defstruct (double-float-datum (:type vector) :named) value) +#+long-float +(defstruct (long-float-datum (:type vector) :named) value) (defstruct (immediate-datum (:type vector) :named) value) (defstruct (datum (:type vector) :named) kind index literal-node-creator) @@ -137,6 +141,8 @@ (entry-point-coalesce (make-similarity-table #'eq)) (package-coalesce (make-similarity-table #'eq)) (double-float-coalesce (make-similarity-table #'eql)) + #+long-float + (long-float-coalesce (make-similarity-table #'eql)) (fcell-coalesce (make-similarity-table #'equal)) (vcell-coalesce (make-similarity-table #'eq)) (llvm-values (make-hash-table)) @@ -447,15 +453,33 @@ rewrite the slot in the literal table to store a closure." (add-creator "ltvc_make_package" index package (load-time-reference-literal (package-name package) read-only-p :toplevelp nil))) +#+short-float/binary16 +(defun ltv/short-float (value index read-only-p &key (toplevelp t)) + (declare (ignore toplevelp read-only-p)) + (let* ((constant (make-short-float-datum :value value))) + (add-creator "ltvc_make_binary16" index value constant))) + (defun ltv/single-float (single index read-only-p &key (toplevelp t)) (declare (ignore toplevelp read-only-p)) (let* ((constant (make-single-float-datum :value single))) - (add-creator "ltvc_make_float" index single constant))) + (add-creator "ltvc_make_binary32" index single constant))) (defun ltv/double-float (double index read-only-p &key (toplevelp t)) (declare (ignore toplevelp read-only-p)) (let* ((constant (make-double-float-datum :value double))) - (add-creator "ltvc_make_double" index double constant))) + (add-creator "ltvc_make_binary64" index double constant))) + +#+long-float/binary80 +(defun ltv/long-float (value index read-only-p &key (toplevelp t)) + (declare (ignore toplevelp read-only-p)) + (let* ((constant (make-long-float-datum :value value))) + (add-creator "ltvc_make_binary80" index value constant))) + +#+long-float/binary128 +(defun ltv/long-float (value index read-only-p &key (toplevelp t)) + (declare (ignore toplevelp read-only-p)) + (let* ((constant (make-long-float-datum :value value))) + (add-creator "ltvc_make_binary128" index value constant))) (defun call-with-constant-arguments-p (form &optional env) (and (consp form) @@ -513,9 +537,13 @@ rewrite the slot in the literal table to store a closure." ((consp object) (values (literal-machine-cons-coalesce *literal-machine*) #'ltv/cons)) ((fixnump object) (values nil #'ltv/fixnum)) ((characterp object) (values nil #'ltv/character)) + #+short-float + ((core:short-float-p object) (values nil #'ltv/short-float)) ((core:single-float-p object) (values nil #'ltv/single-float)) ((symbolp object) (values (literal-machine-symbol-coalesce literal-machine) #'ltv/symbol)) ((double-float-p object) (values (literal-machine-double-float-coalesce literal-machine) #'ltv/double-float)) + #+long-float + ((long-float-p object) (values (literal-machine-long-float-coalesce literal-machine) #'ltv/long-float)) ((core:ratiop object) (values (literal-machine-ratio-coalesce literal-machine) #'ltv/ratio)) ((sys:function-description-p object) (values (literal-machine-function-description-coalesce literal-machine) #'ltv/function-description)) ((sys:core-fun-generator-p object) (values (literal-machine-function-description-coalesce literal-machine) #'ltv/local-entry-point)) @@ -544,8 +572,12 @@ rewrite the slot in the literal table to store a closure." ((core:bignump arg) (core:ltvc-write-bignum arg stream byte-index)) ((immediate-datum-p arg) (core:ltvc-write-object #\i (immediate-datum-value arg) stream byte-index)) + #+short-float + ((short-float-datum-p arg) (core:ltvc-write-short-float (long-float-datum-value arg) stream byte-index)) ((single-float-datum-p arg) (core:ltvc-write-float (single-float-datum-value arg) stream byte-index)) ((double-float-datum-p arg) (core:ltvc-write-double (double-float-datum-value arg) stream byte-index)) + #+long-float + ((long-float-datum-p arg) (core:ltvc-write-long-float (long-float-datum-value arg) stream byte-index)) ((literal-dnode-p arg) (cond ((transient-datum-p (literal-dnode-datum arg)) @@ -960,11 +992,8 @@ and return the sorted values and the constant-table or (values nil nil)." (defun build-c++-byte-codes (primitives) (let ((map (make-hash-table :test #'equal))) - (let ((code 65)) - (dolist (prim primitives) - (let ((func-name (second prim))) - (setf (gethash func-name map) code) - (incf code)))) + (dolist (prim primitives) + (setf (gethash (third prim) map) (first prim))) map)) (defvar *byte-codes* (build-c++-byte-codes cmpref:*startup-primitives-as-list*)) diff --git a/src/lisp/kernel/cmp/cmpltv.lisp b/src/lisp/kernel/cmp/cmpltv.lisp index 4ace44f34e..efc3f295ca 100644 --- a/src/lisp/kernel/cmp/cmpltv.lisp +++ b/src/lisp/kernel/cmp/cmpltv.lisp @@ -144,8 +144,12 @@ :type creator) (%imagpart :initarg :imagpart :reader complex-creator-imagpart :type creator))) +#+short-float +(defclass short-float-creator (number-creator) ()) (defclass single-float-creator (number-creator) ()) (defclass double-float-creator (number-creator) ()) +#+long-float +(defclass long-float-creator (number-creator) ()) (defclass character-creator (vcreator) ()) @@ -587,12 +591,27 @@ ((signed-byte 64) (make-instance 'sb64-creator :prototype value)) (integer (make-instance 'bignum-creator :prototype value))))) -(defmethod add-constant ((value float)) +#+short-float +(defmethod add-constant ((value short-float)) (add-creator value - (etypecase value - (double-float (make-instance 'double-float-creator :prototype value)) - (single-float (make-instance 'single-float-creator :prototype value))))) + (make-instance 'short-float-creator :prototype value))) + +(defmethod add-constant ((value single-float)) + (add-creator + value + (make-instance 'single-float-creator :prototype value))) + +(defmethod add-constant ((value double-float)) + (add-creator + value + (make-instance 'double-float-creator :prototype value))) + +#+long-float +(defmethod add-constant ((value long-float)) + (add-creator + value + (make-instance 'long-float-creator :prototype value))) (defmethod add-constant ((value ratio)) ;; In most cases it's probably pointless to try to coalesce the numerator @@ -819,47 +838,6 @@ ;;; bytes, or etc. powers of two based on how many constants there are. E.g. if ;;; there are 200 constants indices will be one byte, but if there are 300 ;;; indices will be two bytes. -;;; Instruction set is copied from Clasp for now. "sind" in the below means an -;;; index that the allocated object will be stored into. This may need some -;;; review later. -;;; Operations are as follows: -(defparameter +ops+ - '((nil 65 sind) - (t 66 sind) - (ratio 67) - (complex 68) - (cons 69 sind) - (rplaca 70 ind1 ind2) ; (setf (car [ind1]) [ind2]) - (rplacd 71 ind1 ind2) - (make-array 74 sind rank . dims) - (setf-row-major-aref 75 arrayind rmindex valueind) - (make-hash-table 76 sind test count) - (setf-gethash 77 htind keyind valueind) - (make-sb64 78 sind sb64) - (find-package 79 sind nameind) - (make-bignum 80 sind size . words) ; size is signed - (make-symbol 81) ; make-bitvector in clasp - (intern 82 sind packageind nameind) ; make-symbol in clasp - (make-character 83 sind ub32) ; ub64 in clasp, i think? - (make-pathname 85) - (make-bytecode-function 87) ; ltvc_make_global_entry_point - (make-bytecode-module 88) ; ltvc_make_local_entry_point - overriding - (setf-literals 89) ; make_random_state. compatibility is a sham here anyway - (make-single-float 90 sind ub32) - (make-double-float 91 sind ub64) - (funcall-create 93 sind find nargs . args) - (funcall-initialize 94 find nargs . args) - (fdefinition 95 find nameind) - (fcell 96 find nameind) - (vcell 97 vind nameind) - (find-class 98 sind cnind) - ;; set-ltv-funcall in clasp- redundant - #+(or) ; obsolete as of v0.3 - (make-specialized-array 97 sind rank dims etype . elems) - (init-object-array 99 ub64) - (environment 100) - (symbol-value 101) - (attribute 255 name nbytes . data))) ;;; STREAM is a ub8 stream. (defgeneric encode (instruction stream)) @@ -875,16 +853,18 @@ for byte = (ldb (byte 8 i) int) do (write-byte byte stream))) -(defun write-b64 (word stream) (write-b word 8 stream)) -(defun write-b32 (word stream) (write-b word 4 stream)) -(defun write-b16 (word stream) (write-b word 2 stream)) +(defun write-b128 (word stream) (write-b word 16 stream)) +(defun write-b80 (word stream) (write-b word 10 stream)) +(defun write-b64 (word stream) (write-b word 8 stream)) +(defun write-b32 (word stream) (write-b word 4 stream)) +(defun write-b16 (word stream) (write-b word 2 stream)) (defconstant +magic+ #x8d7498b1) ; randomly chosen bytes. (defun write-magic (stream) (write-b32 +magic+ stream)) (defparameter *major-version* 0) -(defparameter *minor-version* 14) +(defparameter *minor-version* 15) (defun write-version (stream) (write-b16 *major-version* stream) @@ -915,7 +895,7 @@ stream))) (defun opcode (mnemonic) - (let ((inst (assoc mnemonic +ops+ :test #'equal))) + (let ((inst (assoc mnemonic cmpref:+bytecode-ltv-ops+ :test #'equal))) (if inst (second inst) (error "unknown mnemonic ~a" mnemonic)))) @@ -936,15 +916,15 @@ ((8) (write-b64 position stream))))) (defmethod encode ((inst cons-creator) stream) - (write-mnemonic 'cons stream)) + (write-mnemonic :cons stream)) (defmethod encode ((inst rplaca-init) stream) - (write-mnemonic 'rplaca stream) + (write-mnemonic :rplaca stream) (write-index (rplac-cons inst) stream) (write-index (rplac-value inst) stream)) (defmethod encode ((inst rplacd-init) stream) - (write-mnemonic 'rplacd stream) + (write-mnemonic :rplacd stream) (write-index (rplac-cons inst) stream) (write-index (rplac-value inst) stream)) @@ -1002,12 +982,12 @@ (error "Code point #x~x is out of range for UTF-8" cpoint)))) (defmethod encode ((inst array-creator) stream) - (write-mnemonic 'make-array stream) + (write-mnemonic :make-array stream) (write-byte (uaet-code inst) stream) (let* ((packing-info (packing-info inst)) (dims (dimensions inst)) (packing-type (first packing-info)) - (packing-code (second packing-info))) + (packing-code (getf cmpref:+uaet-codes+ (second packing-info)))) (write-byte packing-code stream) (write-dimensions dims stream) (macrolet ((dump (&rest forms) @@ -1020,10 +1000,19 @@ (dump (write-byte (char-code elem) stream))) ((equal packing-type 'character) (dump (write-utf8-codepoint (char-code elem) stream))) + #+short-float + ((equal packing-type 'short-float) + (dump (write-b16 (ext:short-float-to-bits elem) stream))) ((equal packing-type 'single-float) (dump (write-b32 (ext:single-float-to-bits elem) stream))) ((equal packing-type 'double-float) (dump (write-b64 (ext:double-float-to-bits elem) stream))) + #+long-float/binary80 + ((equal packing-type 'long-float) + (dump (write-b80 (ext:long-float-to-bits elem) stream))) + #+long-float/binary128 + ((equal packing-type 'long-float) + (dump (write-b128 (ext:long-float-to-bits elem) stream))) ((equal packing-type '(complex single-float)) (dump (write-b32 (ext:single-float-to-bits (realpart elem)) stream) @@ -1063,7 +1052,7 @@ (t (error "BUG: Unknown packing-type ~s" packing-type)))))) (defmethod encode ((inst setf-aref) stream) - (write-mnemonic 'setf-row-major-aref stream) + (write-mnemonic :setf-row-major-aref stream) (write-index (setf-aref-array inst) stream) (write-b16 (setf-aref-index inst) stream) (write-index (setf-aref-value inst) stream)) @@ -1083,30 +1072,37 @@ ;;; will upgrade to ext:byte8 no problem. ;;; TODO: For version 1, put more thought into these IDs. (defvar +array-packing-infos+ - '((nil #b00000000) - (base-char #b10000000) - (character #b11000000) - ;;(short-float #b10100000) ; i.e. binary16 - (single-float #b00100000) ; binary32 - (double-float #b01100000) ; binary64 - ;;(long-float #b11100000) ; binary128? - ;;((complex short...) #b10110000) - ((complex single-float) #b00110000) - ((complex double-float) #b01110000) - ;;((complex long...) #b11110000) - (bit #b00000001) ; (2^(code-1)) bits - ((unsigned-byte 2) #b00000010) - ((unsigned-byte 4) #b00000011) - ((unsigned-byte 8) #b00000100) - ((unsigned-byte 16) #b00000101) - ((unsigned-byte 32) #b00000110) - ((unsigned-byte 64) #b00000111) - ;;((unsigned-byte 128) ??) - ((signed-byte 8) #b10000100) - ((signed-byte 16) #b10000101) - ((signed-byte 32) #b10000110) - ((signed-byte 64) #b10000111) - (t #b11111111))) + '((nil :nil) + (base-char :base-char) + (character :character) + (short-float #+short-float :binary16 + #-short-float :binary32) + (single-float :binary32) + (double-float :binary64) + (long-float #+long-float/binary80 :binary80 + #+long-float/binary128 :binary128 + #-long-float :binary64) + ((complex short-float) #+short-float :complex-binary16 + #-short-float :complex-binary32) + ((complex single-float) :complex-binary32) + ((complex double-float) :complex-binary64) + ((complex long-float) #+long-float/binary80 :complex-binary80 + #+long-float/binary128 :complex-binary128 + #-long-float :complex-binary64) + (bit :unsigned-byte1) + ((unsigned-byte 2) :unsigned-byte2) + ((unsigned-byte 4) :unsigned-byte4) + ((unsigned-byte 8) :unsigned-byte8) + ((unsigned-byte 16) :unsigned-byte16) + ((unsigned-byte 32) :unsigned-byte32) + ((unsigned-byte 64) :unsigned-byte64) + ((unsigned-byte 128) :unsigned-byte128) + ((signed-byte 8) :signed-byte8) + ((signed-byte 16) :signed-byte16) + ((signed-byte 32) :signed-byte32) + ((signed-byte 64) :signed-byte64) + ((signed-byte 128) :signed-byte128) + (t :t))) (defun %uaet-info (uaet) (dolist (info +array-packing-infos+) @@ -1115,7 +1111,8 @@ ;; subtypep not doing so well. default to general. (assoc t +array-packing-infos+)) -(defun find-uaet-code (uaet) (second (%uaet-info uaet))) +(defun find-uaet-code (uaet) + (getf cmpref:+uaet-codes+ (second (%uaet-info uaet)))) (defun array-packing-info (array) ;; TODO? As mentioned above, we could pack arrays more efficiently @@ -1143,40 +1140,40 @@ ;; reaches the rehash threshold. I am not sure how to deal with this ;; in a portable fashion. (we could just invert a provided rehash-size?) (count (min (hash-table-creator-count inst) #xffff))) - (write-mnemonic 'make-hash-table stream) + (write-mnemonic :make-hash-table stream) (write-byte testcode stream) (write-b16 count stream))) (defmethod encode ((inst setf-gethash) stream) - (write-mnemonic 'setf-gethash stream) + (write-mnemonic :setf-gethash stream) (write-index (setf-gethash-hash-table inst) stream) (write-index (setf-gethash-key inst) stream) (write-index (setf-gethash-value inst) stream)) (defmethod encode ((inst singleton-creator) stream) (ecase (prototype inst) - ((nil) (write-mnemonic 'nil stream)) - ((t) (write-mnemonic 't stream)))) + ((nil) (write-mnemonic :nil stream)) + ((t) (write-mnemonic :t stream)))) (defmethod encode ((inst symbol-creator) stream) - (write-mnemonic 'make-symbol stream) + (write-mnemonic :make-symbol stream) (write-index (symbol-creator-name inst) stream)) (defmethod encode ((inst interned-symbol-creator) stream) - (write-mnemonic 'intern stream) + (write-mnemonic :intern stream) (write-index (symbol-creator-package inst) stream) (write-index (symbol-creator-name inst) stream)) (defmethod encode ((inst package-creator) stream) - (write-mnemonic 'find-package stream) + (write-mnemonic :find-package stream) (write-index (package-creator-name inst) stream)) (defmethod encode ((inst character-creator) stream) - (write-mnemonic 'make-character stream) + (write-mnemonic :make-character stream) (write-b32 (char-code (prototype inst)) stream)) (defmethod encode ((inst pathname-creator) stream) - (write-mnemonic 'make-pathname stream) + (write-mnemonic :make-pathname stream) (write-index (pathname-creator-host inst) stream) (write-index (pathname-creator-device inst) stream) (write-index (pathname-creator-directory inst) stream) @@ -1185,12 +1182,12 @@ (write-index (pathname-creator-version inst) stream)) (defmethod encode ((inst sb64-creator) stream) - (write-mnemonic 'make-sb64 stream) + (write-mnemonic :make-sb64 stream) (write-b64 (prototype inst) stream)) (defmethod encode ((inst bignum-creator) stream) ;; uses sign-magnitude representation. - (write-mnemonic 'make-bignum stream) + (write-mnemonic :make-bignum stream) (let* ((number (prototype inst)) (anumber (abs number)) (nwords (ceiling (integer-length anumber) 64)) @@ -1201,63 +1198,78 @@ for word = (ldb (byte 64 pos) anumber) do (write-b64 word stream)))) +#+short-float/binary16 +(defmethod encode ((inst short-float-creator) stream) + (write-mnemonic :make-binary16 stream) + (write-b16 (ext:short-float-to-bits (prototype inst)) stream)) + (defmethod encode ((inst single-float-creator) stream) - (write-mnemonic 'make-single-float stream) + (write-mnemonic :make-binary32 stream) (write-b32 (ext:single-float-to-bits (prototype inst)) stream)) (defmethod encode ((inst double-float-creator) stream) - (write-mnemonic 'make-double-float stream) + (write-mnemonic :make-binary64 stream) (write-b64 (ext:double-float-to-bits (prototype inst)) stream)) +#+long-float/binary80 +(defmethod encode ((inst long-float-creator) stream) + (write-mnemonic :make-binary80 stream) + (write-b80 (ext:long-float-to-bits (prototype inst)) stream)) + +#+long-float/binary128 +(defmethod encode ((inst long-float-creator) stream) + (write-mnemonic :make-binary128 stream) + (write-b128 (ext:long-float-to-bits (prototype inst)) stream)) + (defmethod encode ((inst ratio-creator) stream) - (write-mnemonic 'ratio stream) + (write-mnemonic :ratio stream) (write-index (ratio-creator-numerator inst) stream) (write-index (ratio-creator-denominator inst) stream)) (defmethod encode ((inst complex-creator) stream) - (write-mnemonic 'complex stream) + (write-mnemonic :complex stream) (write-index (complex-creator-realpart inst) stream) (write-index (complex-creator-imagpart inst) stream)) (defmethod encode ((inst fdefinition-lookup) stream) - (write-mnemonic 'fdefinition stream) + (write-mnemonic :fdefinition stream) (write-index (name inst) stream)) (defmethod encode ((inst fcell-lookup) stream) - (write-mnemonic 'fcell stream) + (write-mnemonic :fcell stream) (write-index (name inst) stream)) (defmethod encode ((inst vcell-lookup) stream) - (write-mnemonic 'vcell stream) + (write-mnemonic :vcell stream) (write-index (name inst) stream)) (defmethod encode ((inst environment-lookup) stream) - (write-mnemonic 'environment stream)) + (write-mnemonic :environment stream)) (defmethod encode ((inst vdefinition) stream) - (write-mnemonic 'symbol-value stream) + (write-mnemonic :symbol-value stream) (write-index (name inst) stream)) (defmethod encode ((inst general-creator) stream) - (write-mnemonic 'funcall-create stream) + (write-mnemonic :funcall-create stream) (write-index (general-function inst) stream) (write-b16 (length (general-arguments inst)) stream) (loop for arg in (general-arguments inst) do (write-index arg stream))) (defmethod encode ((inst general-initializer) stream) - (write-mnemonic 'funcall-initialize stream) + (write-mnemonic :funcall-initialize stream) (write-index (general-function inst) stream) (write-b16 (length (general-arguments inst)) stream) (loop for arg in (general-arguments inst) do (write-index arg stream))) (defmethod encode ((inst class-creator) stream) - (write-mnemonic 'find-class stream) + (write-mnemonic :find-class stream) (write-index (class-creator-name inst) stream)) (defmethod encode ((inst load-time-value-creator) stream) - (write-mnemonic 'funcall-create stream) + (write-mnemonic :funcall-create stream) (write-index (load-time-value-creator-function inst) stream) ;; no arguments (write-b16 0 stream)) @@ -1336,7 +1348,7 @@ (defmethod encode ((inst bytefunction-creator) stream) ;; four bytes for the entry point, two for the nlocals and nclosed, ;; then indices. - (write-mnemonic 'make-bytecode-function stream) + (write-mnemonic :make-bytecode-function stream) (write-b32 (entry-point inst) stream) (write-b32 (size inst) stream) (write-b16 (nlocals inst) stream) @@ -1578,7 +1590,7 @@ (defmethod encode ((inst bytemodule-creator) stream) ;; Write instructions. - (write-mnemonic 'make-bytecode-module stream) + (write-mnemonic :make-bytecode-module stream) (let* ((lispcode (bytemodule-lispcode inst)) (len (length lispcode))) (when (> len #.(ash 1 32)) @@ -1587,7 +1599,7 @@ (write-sequence lispcode stream))) (defmethod encode ((inst setf-literals) stream) - (write-mnemonic 'setf-literals stream) + (write-mnemonic :setf-literals stream) (write-index (setf-literals-module inst) stream) (let ((literals (setf-literals-literals inst))) (write-b16 (length literals) stream) @@ -1597,7 +1609,7 @@ ;;; (defmethod encode :before ((attr attribute) stream) - (write-mnemonic 'attribute stream) + (write-mnemonic :attribute stream) (write-index (name attr) stream)) (defmethod encode ((attr unknown-attr) stream) @@ -1636,23 +1648,9 @@ (write-b64 (column attr) stream) (write-b64 (filepos attr) stream)) -(defvar +debug-info-ops+ - '((function 0) - (vars 1) - (location 2) - (decls 3) - (the 4) - (block 5) - (exit 6) - (macro 7) - (if 8) - (tagbody 9))) - (defun debug-info-opcode (mnemonic) - (let ((inst (assoc mnemonic +debug-info-ops+))) - (if inst - (second inst) - (error "unknown debug info mnemonic ~a" mnemonic)))) + (or (getf cmpref:+debug-info-ops+ mnemonic) + (error "unknown debug info mnemonic ~a" mnemonic))) (defun write-debug-info-mnemonic (mnemonic stream) (write-byte (debug-info-opcode mnemonic) stream)) @@ -1660,7 +1658,7 @@ (defgeneric info-length (info)) (defmethod encode ((info debug-info-function) stream) - (write-debug-info-mnemonic 'function stream) + (write-debug-info-mnemonic :function stream) (write-index (di-function info) stream)) (defmethod info-length ((info debug-info-function)) (+ 1 *index-bytes*)) @@ -1682,7 +1680,7 @@ result)) (defmethod encode ((info debug-info-vars) stream) - (write-debug-info-mnemonic 'vars stream) + (write-debug-info-mnemonic :vars stream) (write-b32 (di-start info) stream) (write-b32 (di-end info) stream) (let ((vars (vars info))) @@ -1701,7 +1699,7 @@ sum (* *index-bytes* (length (decls var)))))) (defmethod encode ((info debug-info-location) stream) - (write-debug-info-mnemonic 'location stream) + (write-debug-info-mnemonic :location stream) (write-b32 (di-start info) stream) (write-b32 (di-end info) stream) (write-index (di-pathname info) stream) @@ -1712,7 +1710,7 @@ (+ 1 4 4 *index-bytes* 8 8 8)) (defmethod encode ((info debug-info-decls) stream) - (write-debug-info-mnemonic 'decls stream) + (write-debug-info-mnemonic :decls stream) (write-b32 (di-start info) stream) (write-b32 (di-end info) stream) (write-index (decls info) stream)) @@ -1720,7 +1718,7 @@ (+ 1 4 4 *index-bytes*)) (defmethod encode ((info debug-info-the) stream) - (write-debug-info-mnemonic 'the stream) + (write-debug-info-mnemonic :the stream) (write-b32 (di-start info) stream) (write-b32 (di-end info) stream) (write-index (di-type info) stream) @@ -1729,7 +1727,7 @@ (+ 1 4 4 *index-bytes* 4)) (defmethod encode ((info debug-ast-if) stream) - (write-debug-info-mnemonic 'if stream) + (write-debug-info-mnemonic :if stream) (write-b32 (di-start info) stream) (write-b32 (di-end info) stream) (write-b32 (di-receiving info) stream)) @@ -1737,7 +1735,7 @@ (+ 1 4 4 4)) (defmethod encode ((info debug-ast-tagbody) stream) - (write-debug-info-mnemonic 'tagbody stream) + (write-debug-info-mnemonic :tagbody stream) (write-b32 (di-start info) stream) (write-b32 (di-end info) stream) (write-b16 (length (di-tags info)) stream) @@ -1749,7 +1747,7 @@ (+ *index-bytes* 4)))) (defmethod encode ((info debug-info-block) stream) - (write-debug-info-mnemonic 'block stream) + (write-debug-info-mnemonic :block stream) (write-b32 (di-start info) stream) (write-b32 (di-end info) stream) (write-index (name info) stream) @@ -1758,7 +1756,7 @@ (+ 1 4 4 *index-bytes* 4)) (defmethod encode ((info debug-info-exit) stream) - (write-debug-info-mnemonic 'exit stream) + (write-debug-info-mnemonic :exit stream) (write-b32 (di-start info) stream) (write-b32 (di-end info) stream) (write-b32 (di-receiving info) stream)) @@ -1766,7 +1764,7 @@ (+ 1 4 4 4)) (defmethod encode ((info debug-info-macroexpansion) stream) - (write-debug-info-mnemonic 'macro stream) + (write-debug-info-mnemonic :macro stream) (write-b32 (di-start info) stream) (write-b32 (di-end info) stream) (write-index (di-macro-name info) stream)) @@ -1807,7 +1805,7 @@ do (write-index creator stream)))) (defmethod encode ((init init-object-array) stream) - (write-mnemonic 'init-object-array stream) + (write-mnemonic :init-object-array stream) (write-b64 (init-object-array-count init) stream)) ;;; diff --git a/src/lisp/kernel/cmp/disltv.lisp b/src/lisp/kernel/cmp/disltv.lisp index ab3e55fb69..728a078957 100644 --- a/src/lisp/kernel/cmp/disltv.lisp +++ b/src/lisp/kernel/cmp/disltv.lisp @@ -121,33 +121,33 @@ ;;; Return a new INSTRUCTION instance. (defgeneric %load-instruction (mnemonic stream)) -(defmethod %load-instruction ((mnemonic (eql 'nil)) stream) +(defmethod %load-instruction ((mnemonic (eql :nil)) stream) (declare (ignore stream)) (let ((index (next-index))) (dbgprint " (nil ~d)" index) (setf (creator index) (make-instance 'singleton-creator :prototype nil)))) -(defmethod %load-instruction ((mnemonic (eql 't)) stream) +(defmethod %load-instruction ((mnemonic (eql :t)) stream) (declare (ignore stream)) (let ((index (next-index))) (dbgprint " (t ~d)" index) (setf (creator index) (make-instance 'singleton-creator :prototype t)))) -(defmethod %load-instruction ((mnemonic (eql 'cons)) stream) +(defmethod %load-instruction ((mnemonic (eql :cons)) stream) (declare (ignore stream)) (let ((index (next-index))) (dbgprint " (cons ~d)" index) (setf (creator index) (make-instance 'cons-creator)))) -(defmethod %load-instruction ((mnemonic (eql 'rplaca)) stream) +(defmethod %load-instruction ((mnemonic (eql :rplaca)) stream) (let ((cons (read-creator stream)) (value (read-creator stream))) (dbgprint " (rplaca ~s ~s)" cons value) (make-instance 'rplaca-init :cons cons :value value))) -(defmethod %load-instruction ((mnemonic (eql 'rplacd)) stream) +(defmethod %load-instruction ((mnemonic (eql :rplacd)) stream) (let ((cons (read-creator stream)) (value (read-creator stream))) (dbgprint " (rplacd ~s ~s)" cons value) (make-instance 'rplacd-init :cons cons :value value))) @@ -207,7 +207,7 @@ (t ; invalid. should we err or just warn? (error "Invalid UTF-8 header byte: ~x" b0))))) -(defmethod %load-instruction ((mnemonic (eql 'make-array)) stream) +(defmethod %load-instruction ((mnemonic (eql :make-array)) stream) (let* ((index (next-index)) (uaet-code (read-byte stream)) (uaet (decode-uaet uaet-code)) (packing-code (read-byte stream)) @@ -276,13 +276,13 @@ :uaet-code uaet-code :prototype array))))) -(defmethod %load-instruction ((mnemonic (eql 'setf-row-major-aref)) stream) +(defmethod %load-instruction ((mnemonic (eql :setf-row-major-aref)) stream) (let ((array (read-creator stream)) (index (read-ub16 stream)) (value (read-creator stream))) (dbgprint " (setf (row-major-aref ~s ~d) ~s)" array index value) (make-instance 'setf-aref :array array :index index :value value))) -(defmethod %load-instruction ((mnemonic (eql 'make-hash-table)) stream) +(defmethod %load-instruction ((mnemonic (eql :make-hash-table)) stream) (let* ((index (next-index)) (testcode (read-byte stream)) (test (ecase testcode ((#b00) 'eq) @@ -294,25 +294,25 @@ (setf (creator index) (make-instance 'hash-table-creator :test test :count count)))) -(defmethod %load-instruction ((mnemonic (eql 'setf-gethash)) stream) +(defmethod %load-instruction ((mnemonic (eql :setf-gethash)) stream) (let ((ht (read-creator stream)) (key (read-creator stream)) (value (read-creator stream))) (dbgprint " (setf (gethash ~s ~s) ~s)" key ht value) (make-instance 'setf-gethash :hash-table ht :key key :value value))) -(defmethod %load-instruction ((mnemonic (eql 'make-sb64)) stream) +(defmethod %load-instruction ((mnemonic (eql :make-sb64)) stream) (let ((index (next-index)) (fix (read-sb64 stream))) (dbgprint " (make-sb64 ~d ~d)" index fix) (setf (creator index) (make-instance 'sb64-creator :prototype fix)))) -(defmethod %load-instruction ((mnemonic (eql 'find-package)) stream) +(defmethod %load-instruction ((mnemonic (eql :find-package)) stream) (let ((index (next-index)) (name (read-creator stream))) (dbgprint " (find-package ~d ~s)" index name) (setf (creator index) (make-instance 'package-creator :name name)))) -(defmethod %load-instruction ((mnemonic (eql 'make-bignum)) stream) +(defmethod %load-instruction ((mnemonic (eql :make-bignum)) stream) (let* ((index (next-index)) (ssize (read-sb64 stream)) (result 0) (size (abs ssize))) (loop repeat size @@ -322,40 +322,40 @@ (dbgprint " (make-bignum ~d ~d ~d)" index ssize result) (setf (creator index) (make-instance 'bignum-creator :prototype result)))) -(defmethod %load-instruction ((mnemonic (eql 'make-single-float)) stream) +(defmethod %load-instruction ((mnemonic (eql :make-binary32)) stream) (let ((index (next-index)) (float (ext:bits-to-single-float (read-ub32 stream)))) (dbgprint " (make-single-float ~d ~e)" index float) (setf (creator index) (make-instance 'single-float-creator :prototype float)))) -(defmethod %load-instruction ((mnemonic (eql 'make-double-float)) stream) +(defmethod %load-instruction ((mnemonic (eql :make-binary64)) stream) (let ((index (next-index)) (float (ext:bits-to-double-float (read-ub64 stream)))) (dbgprint " (make-double-float ~d ~e)" index float) (setf (creator index) (make-instance 'double-float-creator :prototype float)))) -(defmethod %load-instruction ((mnemonic (eql 'ratio)) stream) +(defmethod %load-instruction ((mnemonic (eql :ratio)) stream) (let ((index (next-index)) (num (read-creator stream)) (den (read-creator stream))) (dbgprint " (ratio ~d ~d ~d)" index num den) (setf (creator index) (make-instance 'ratio-creator :numerator num :denominator den)))) -(defmethod %load-instruction ((mnemonic (eql 'complex)) stream) +(defmethod %load-instruction ((mnemonic (eql :complex)) stream) (let ((index (next-index)) (real (read-creator stream)) (imag (read-creator stream))) (dbgprint " (complex ~d ~s ~s)" index real imag) (setf (creator index) (make-instance 'complex-creator :realpart real :imagpart imag)))) -(defmethod %load-instruction ((mnemonic (eql 'make-symbol)) stream) +(defmethod %load-instruction ((mnemonic (eql :make-symbol)) stream) (let ((index (next-index)) (name (read-creator stream))) (dbgprint " (make-symbol ~d ~s)" index name) (setf (creator index) (make-instance 'symbol-creator :name name)))) -(defmethod %load-instruction ((mnemonic (eql 'intern)) stream) +(defmethod %load-instruction ((mnemonic (eql :intern)) stream) (let ((index (next-index)) (pkg (read-creator stream)) (name (read-creator stream))) (dbgprint " (intern ~d ~s ~s)" index name pkg) @@ -363,13 +363,13 @@ (make-instance 'interned-symbol-creator :package pkg :name name)))) -(defmethod %load-instruction ((mnemonic (eql 'make-character)) stream) +(defmethod %load-instruction ((mnemonic (eql :make-character)) stream) (let ((index (next-index)) (char (code-char (read-ub32 stream)))) (dbgprint " (make-character ~d ~:c)" index char) (setf (creator index) (make-instance 'character-creator :prototype char)))) -(defmethod %load-instruction ((mnemonic (eql 'make-pathname)) stream) +(defmethod %load-instruction ((mnemonic (eql :make-pathname)) stream) (let ((index (next-index)) (host (read-creator stream)) (device (read-creator stream)) (directory (read-creator stream)) (name (read-creator stream)) @@ -382,7 +382,7 @@ :directory directory :name name :type type :version version)))) -(defmethod %load-instruction ((mnemonic (eql 'make-bytecode-function)) stream) +(defmethod %load-instruction ((mnemonic (eql :make-bytecode-function)) stream) (let ((index (next-index)) (entry-point (read-ub32 stream)) (size (if (and (= *load-major* 0) (< *load-minor* 8)) @@ -398,7 +398,7 @@ :nlocals nlocals :nclosed nclosed :module module)))) -(defmethod %load-instruction ((mnemonic (eql 'make-bytecode-module)) stream) +(defmethod %load-instruction ((mnemonic (eql :make-bytecode-module)) stream) (let ((index (next-index)) (len (read-ub32 stream))) (dbgprint " (make-bytecode-module ~d ~d)" index len) (setf (creator index) @@ -406,7 +406,7 @@ (read-sequence lispcode stream) (make-instance 'bytemodule-creator :lispcode lispcode))))) -(defmethod %load-instruction ((mnemonic (eql 'setf-literals)) stream) +(defmethod %load-instruction ((mnemonic (eql :setf-literals)) stream) (if (and (= *load-major* 0) (<= *load-minor* 6)) (let ((module (read-creator stream)) (literals (read-creator stream))) (dbgprint " (setf (literals ~s) ~s)" module literals) @@ -420,26 +420,26 @@ (make-instance 'setf-literals :module module :literals literals)))) -(defmethod %load-instruction ((mnemonic (eql 'fdefinition)) stream) +(defmethod %load-instruction ((mnemonic (eql :fdefinition)) stream) (let ((index (next-index)) (name (read-creator stream))) (dbgprint " (fdefinition ~d ~s)" index name) (setf (creator index) (make-instance 'fdefinition-lookup :name name)))) -(defmethod %load-instruction ((mnemonic (eql 'fcell)) stream) +(defmethod %load-instruction ((mnemonic (eql :fcell)) stream) (let ((index (next-index)) (name (read-creator stream))) (dbgprint " (fcell ~d ~s)" index name) (setf (creator index) (make-instance 'fcell-lookup :name name)))) -(defmethod %load-instruction ((mnemonic (eql 'vcell)) stream) +(defmethod %load-instruction ((mnemonic (eql :vcell)) stream) (let ((index (next-index)) (name (read-creator stream))) (dbgprint " (vcell ~d ~s)" index name) (setf (creator index) (make-instance 'vcell-lookup :name name)))) -(defmethod %load-instruction ((mnemonic (eql 'symbol-value)) stream) +(defmethod %load-instruction ((mnemonic (eql :symbol-value)) stream) (let ((index (next-index)) (name (read-creator stream))) (setf (creator index) (make-instance 'vdefinition :name name)))) -(defmethod %load-instruction ((mnemonic (eql 'funcall-create)) stream) +(defmethod %load-instruction ((mnemonic (eql :funcall-create)) stream) (let ((index (next-index)) (fun (read-creator stream)) (args (if (and (= *load-major* 0) (<= *load-minor* 4)) () @@ -450,7 +450,7 @@ (make-instance 'general-creator :function fun :arguments args)))) -(defmethod %load-instruction ((mnemonic (eql 'funcall-initialize)) stream) +(defmethod %load-instruction ((mnemonic (eql :funcall-initialize)) stream) (let ((fun (read-creator stream)) (args (if (and (= *load-major* 0) (<= *load-minor* 4)) () @@ -459,12 +459,12 @@ (dbgprint " (funcall-initialize ~s~{ ~s~})" fun args) (make-instance 'general-initializer :function fun :arguments args))) -(defmethod %load-instruction ((mnemonic (eql 'find-class)) stream) +(defmethod %load-instruction ((mnemonic (eql :find-class)) stream) (let ((index (next-index)) (name (read-creator stream))) (dbgprint " (find-class ~d ~s)" index name) (setf (creator index) (make-instance 'class-creator :name name)))) -(defmethod %load-instruction ((mnemonic (eql 'init-object-array)) stream) +(defmethod %load-instruction ((mnemonic (eql :init-object-array)) stream) (let ((nobjs (read-ub64 stream))) (dbgprint " (init-object-array ~d)" nobjs) (setf *index-bytes* (max (ash 1 (1- (ceiling (integer-length nobjs) 8))) @@ -475,7 +475,7 @@ (defun read-mnemonic (stream) (let* ((opcode (read-byte stream)) - (info (find opcode +ops+ :key #'second))) + (info (find opcode cmpref:+bytecode-ltv-ops+ :key #'second))) (if info (first info) (error "BUG: Unknown opcode ~x" opcode)))) @@ -504,7 +504,7 @@ (make-instance 'unknown-attr :name ncreator :bytes bytes))) #+clasp -(defmethod %load-attribute ((mnemonic (eql 'source-pos-info)) ncreator stream) +(defmethod %load-attribute ((mnemonic (eql :source-pos-info)) ncreator stream) (let ((nbytes (read-ub32 stream)) (fun (read-creator stream)) (path (read-creator stream)) (line (read-ub64 stream)) (col (read-ub64 stream)) @@ -516,7 +516,7 @@ :lineno line :column col :filepos pos))) #+clasp -(defmethod %load-attribute ((mnemonic (eql 'module-debug-info)) ncreator stream) +(defmethod %load-attribute ((mnemonic (eql :module-debug-info)) ncreator stream) (read-ub32 stream) ; nbytes (let* ((mod (read-creator stream)) (ninfos (read-ub32 stream)) @@ -538,11 +538,11 @@ (defun load-debug-info (stream) (%load-debug-info (read-di-mnemonic stream) stream)) -(defmethod %load-debug-info ((mnemonic (eql 'function)) stream) +(defmethod %load-debug-info ((mnemonic (eql :function)) stream) (make-instance 'debug-info-function :function (read-creator stream))) -(defmethod %load-debug-info ((mnemonic (eql 'vars)) stream) +(defmethod %load-debug-info ((mnemonic (eql :vars)) stream) (make-instance 'debug-info-vars :start (read-ub32 stream) :end (read-ub32 stream) :vars (loop repeat (read-ub16 stream) @@ -566,7 +566,7 @@ :cellp cellp :dxp dx :ignore ignore :inline inline :decls decls)))) -(defmethod %load-debug-info ((mnemonic (eql 'location)) stream) +(defmethod %load-debug-info ((mnemonic (eql :location)) stream) (make-instance 'debug-info-location :start (read-ub32 stream) :end (read-ub32 stream) @@ -575,25 +575,25 @@ :column (read-ub64 stream) :filepos (read-ub64 stream))) -(defmethod %load-debug-info ((mnemonic (eql 'decls)) stream) +(defmethod %load-debug-info ((mnemonic (eql :decls)) stream) (make-instance 'debug-info-decls :start (read-ub32 stream) :end (read-ub32 stream) :decls (read-creator stream))) -(defmethod %load-debug-info ((mnemonic (eql 'the)) stream) +(defmethod %load-debug-info ((mnemonic (eql :the)) stream) (make-instance 'debug-info-the :start (read-ub32 stream) :end (read-ub32 stream) :type (read-creator stream) :receiving (read-sb32 stream))) -(defmethod %load-debug-info ((mnemonic (eql 'if)) stream) +(defmethod %load-debug-info ((mnemonic (eql :if)) stream) (make-instance 'debug-ast-if :start (read-ub32 stream) :end (read-ub32 stream) :receiving (read-sb32 stream))) -(defmethod %load-debug-info ((mnemonic (eql 'tagbody)) stream) +(defmethod %load-debug-info ((mnemonic (eql :tagbody)) stream) (make-instance 'debug-ast-tagbody :start (read-ub32 stream) :end (read-ub32 stream) :tags (loop repeat (read-ub16 stream) @@ -601,18 +601,18 @@ for ip = (read-ub32 stream) collect (cons tag ip)))) -(defmethod %load-debug-info ((mnemonic (eql 'block)) stream) +(defmethod %load-debug-info ((mnemonic (eql :block)) stream) (make-instance 'debug-info-block :start (read-ub32 stream) :end (read-ub32 stream) :name (read-creator stream) :receiving (read-sb32 stream))) -(defmethod %load-debug-info ((mnemonic (eql 'exit)) stream) +(defmethod %load-debug-info ((mnemonic (eql :exit)) stream) (make-instance 'debug-info-exit :start (read-ub32 stream) :end (read-ub32 stream) :receiving (read-sb32 stream))) -(defmethod %load-debug-info ((mnemonic (eql 'macro)) stream) +(defmethod %load-debug-info ((mnemonic (eql :macro)) stream) (make-instance 'debug-info-macroexpansion :start (read-ub32 stream) :end (read-ub32 stream) :macro-name (read-creator stream))) @@ -634,7 +634,7 @@ acreator)))) (%load-attribute (or (gethash aname *attr-map*) aname) acreator stream))) -(defmethod %load-instruction ((mnemonic (eql 'attribute)) stream) +(defmethod %load-instruction ((mnemonic (eql :attribute)) stream) (load-attribute stream)) ;;; diff --git a/src/lisp/kernel/cmp/opt/opt-array.lisp b/src/lisp/kernel/cmp/opt/opt-array.lisp index 1450d9938d..40f71264d4 100644 --- a/src/lisp/kernel/cmp/opt/opt-array.lisp +++ b/src/lisp/kernel/cmp/opt/opt-array.lisp @@ -14,6 +14,10 @@ ((character) (values 'core:make-simple-vector-character 'core:make-simple-mdarray-character)) ((single-float) (values 'core:make-simple-vector-single-float 'core:make-simple-mdarray-single-float)) ((double-float) (values 'core:make-simple-vector-double-float 'core:make-simple-mdarray-double-float)) + #+short-float + ((short-float) (values 'core:make-simple-vector-short-float 'core:make-simple-mdarray-short-float)) + #+long-float + ((long-float) (values 'core:make-simple-vector-long-float 'core:make-simple-mdarray-long-float)) ((ext:integer2) (values 'core:make-simple-vector-int2 'core:make-simple-mdarray-int2)) ((ext:byte2) (values 'core:make-simple-vector-byte2 'core:make-simple-mdarray-byte2)) ((ext:integer4) (values 'core:make-simple-vector-int4 'core:make-simple-mdarray-int4)) diff --git a/src/lisp/kernel/cmp/opt/opt-sequence.lisp b/src/lisp/kernel/cmp/opt/opt-sequence.lisp index c4389166b0..ed5f0e2824 100644 --- a/src/lisp/kernel/cmp/opt/opt-sequence.lisp +++ b/src/lisp/kernel/cmp/opt/opt-sequence.lisp @@ -56,7 +56,8 @@ ;; (make-sequence nil...) is weird shit that we leave to runtime. form) ((eq kind 'list) - (let ((ss (gensym "SIZE")) (r (gensym "RESULT"))) + (let ((ss (gensym "SIZE")) + (r (gensym "RESULT"))) `(let* ((,ss ,size) (,r (make-list ,ss :initial-element ,initial-element))) ,@(when length @@ -64,15 +65,15 @@ (core::error-sequence-length ,r ',type ,ss)))) ,r))) ((consp kind) ; (VECTOR uaet) - (let ((uaet (second kind)) (r (gensym "RESULT")) (ss (gensym "SIZE"))) + (let ((uaet (second kind)) + (r (gensym "RESULT")) + (ss (gensym "SIZE"))) `(let* ((,ss ,size) ;; negative size will crash sys:make-vector (,r (if (< ,ss 0) (error 'type-error :datum ,ss :expected-type '(integer 0 *)) - (sys:make-vector ',uaet ,ss)))) - ,@(when iesp - `((si::fill-array-with-elt ,r ,initial-element 0 nil))) + (sys:make-vector ',uaet ,ss nil nil nil 0 ,initial-element ,iesp)))) ,@(unless (null length) `((unless (eql ,ss ',length) (si::error-sequence-length ,r ',type ,ss)))) diff --git a/src/lisp/kernel/cmp/opt/opt-type.lisp b/src/lisp/kernel/cmp/opt/opt-type.lisp index 49e2ee55db..55d77a490f 100644 --- a/src/lisp/kernel/cmp/opt/opt-type.lisp +++ b/src/lisp/kernel/cmp/opt/opt-type.lisp @@ -306,29 +306,32 @@ (if (ratiop object) ,(real-interval-test `(the ratio object) low high) nil))) - ;; only singles and doubles actually exist. - ;; FIXME: write in this assumption better in case we change it later. - ((short-float single-float) + #+short-float + ((short-float) + `(if (core:short-float-p object) + ,(real-interval-test `(the ,head object) low high) + nil)) + ((#-short-float short-float single-float) `(if (core:single-float-p object) ,(real-interval-test `(the ,head object) low high) nil)) - ((double-float long-float) + ((double-float #-long-float long-float) `(if (core:double-float-p object) ,(real-interval-test `(the ,head object) low high) nil)) + #+long-float + ((long-float) + `(if (core:long-float-p object) + ,(real-interval-test `(the ,head object) low high) + nil)) ((float) - `(if (if (core:single-float-p object) - t - (if (core:double-float-p object) t nil)) + `(if (floatp object) ,(real-interval-test `(the float object) low high) nil)) ((real) `(or ,(integral-interval-typep-form low high) - (if (if (core:single-float-p object) - t - (if (core:double-float-p object) - t - (if (ratiop object) t nil))) + (if (or (floatp object) + (rationalp object)) ,(real-interval-test '(the real object) low high) nil)))))) @@ -466,10 +469,14 @@ ((character base-char) (da `(character object))) ;; make sure we don't convert other floats ((float) (da `(if (floatp object) object (float object)))) - ((short-float) (da `(float object 0.0s0))) - ((single-float) (da `(float object 0.0f0))) - ((double-float) (da `(float object 0.0d0))) - ((long-float) (da `(float object 0.0l0))) + #+short-float + ((short-float) (da `(core:to-short-float object))) + ((#-short-float short-float single-float) + (da `(core:to-single-float object))) + ((double-float #-long-float long-float) + (da `(core:to-double-float object))) + #+long-float + ((long-float) (da `(core:to-long-float object))) ((function) (da `(coerce-to-function object))) ((complex) ;; This is the only case where the returned value diff --git a/src/lisp/kernel/cmp/primitives.lisp b/src/lisp/kernel/cmp/primitives.lisp index 00578ba4c7..68ff2e3638 100644 --- a/src/lisp/kernel/cmp/primitives.lisp +++ b/src/lisp/kernel/cmp/primitives.lisp @@ -74,11 +74,11 @@ "ltvc functions are used to construct the byte-code interpreter" `(progn ,@(mapcar (lambda (op) - (list* (if (first op) 'primitive-unwinds 'primitive) - (second op) + (list* (if (second op) 'primitive-unwinds 'primitive) + (third op) :ltvc-return - (list* 'list :gcroots-in-module* (third op)) - :ltvc t (cdddr op))) + (list* 'list :gcroots-in-module* (fourth op)) + :ltvc t (cddddr op))) cmpref:*startup-primitives-as-list*) ,@'((primitive "ltvc_lookup_literal" :t* (list :gcroots-in-module* :size_t)) (primitive "ltvc_lookup_transient" :t* (list :gcroots-in-module* :i8 :size_t)) @@ -421,8 +421,13 @@ (defun lookup-type (type-name) (case type-name (:bignum %bignum%) - (:double-float %double%) + #+short-float (:short-float %short-float%) + #+short-float (:binary16 %short-float%) (:single-float %float%) + (:double-float %double%) + #+long-float (:long-float %long-float%) + #+long-float (:binary80 %long-float%) + #+long-float (:binary128 %long-float%) (:fn-start-up* %fn-start-up*%) (:gcroots-in-module* %gcroots-in-module*%) (:i1 %i1%) @@ -435,7 +440,6 @@ (:i8* %i8*%) (:i8** %i8**%) (:jmp-buf-tag* %jmp-buf-tag*%) - #+long-float (:long-float %long-float%) (:ltv** %ltv**%) (:ltvc-return %ltvc-return%) (:metadata %metadata%) diff --git a/src/lisp/kernel/cmp/startup-primitives.lisp b/src/lisp/kernel/cmp/startup-primitives.lisp index b3d9d305f1..021f71e606 100644 --- a/src/lisp/kernel/cmp/startup-primitives.lisp +++ b/src/lisp/kernel/cmp/startup-primitives.lisp @@ -4,6 +4,9 @@ (in-package #:cmpref)) (export '(*startup-primitives-as-list* + +bytecode-ltv-ops+ + +uaet-codes+ + +debug-info-ops+ generate-virtual-machine-header)) (in-package #:cmpref) @@ -26,39 +29,129 @@ ;;; (defvar *startup-primitives-as-list* ;; (unwindsp name argtypes &key varargs) - '((nil "ltvc_make_nil" (:i8 :size_t)) - (nil "ltvc_make_t" (:i8 :size_t)) - (nil "ltvc_make_ratio" (:i8 :size_t :t* :t*)) - (nil "ltvc_make_complex" (:i8 :size_t :t* :t*)) - (nil "ltvc_make_cons" (:i8 :size_t)) - (nil "ltvc_rplaca" (:t* :t*)) - (nil "ltvc_rplacd" (:t* :t*)) - (nil "ltvc_make_list" (:i8 :size_t :size_t)) - (nil "ltvc_fill_list" (:t* :size_t) :varargs t) - (nil "ltvc_make_array" (:i8 :size_t :t* :t*)) - (nil "ltvc_setf_row_major_aref" (:t* :size_t :t*)) - (nil "ltvc_make_hash_table" (:i8 :size_t :t*)) - (nil "ltvc_setf_gethash" (:t* :t* :t*)) - (nil "ltvc_make_fixnum" (:i8 :size_t :uintptr_t)) - (nil "ltvc_make_package" (:i8 :size_t :t*)) - (nil "ltvc_make_next_bignum" (:i8 :size_t :bignum)) - (nil "ltvc_make_bitvector" (:i8 :size_t :t*)) - (nil "ltvc_make_symbol" (:i8 :size_t :t* :t*)) - (nil "ltvc_make_character" (:i8 :size_t :uintptr_t)) - (nil "ltvc_make_base_string" (:i8 :size_t :i8*)) - (nil "ltvc_make_pathname" (:i8 :size_t :t* :t* :t* :t* :t* :t*)) - (nil "ltvc_make_function_description" (:i8 :size_t :t* :t* :t* :t* :t* :size_t - :size_t :size_t)) - (nil "ltvc_make_global_entry_point" (:i8 :size_t :size_t :t* :size_t)) - (nil "ltvc_make_local_entry_point" (:i8 :size_t :size_t :t*)) - (nil "ltvc_ensure_fcell" (:i8 :size_t :t*)) - (nil "ltvc_ensure_vcell" (:i8 :size_t :t*)) - (nil "ltvc_make_random_state" (:i8 :size_t :t*)) - (nil "ltvc_make_float" (:i8 :size_t :single-float)) - (nil "ltvc_make_double" (:i8 :size_t :double-float)) - (t "ltvc_set_mlf_creator_funcall" (:i8 :size_t :size_t :i8*)) - (t "ltvc_mlf_init_funcall" (:size_t :i8*)) - (t "ltvc_mlf_init_basic_call" (:t* :size_t) :varargs t) - (t "ltvc_mlf_create_basic_call" (:i8 :size_t :t* :size_t) :varargs t) - (t "ltvc_set_ltv_funcall" (:i8 :size_t :size_t :i8*)) - (t "ltvc_toplevel_funcall" (:size_t :i8*)))) + '(( 65 nil "ltvc_make_nil" (:i8 :size_t)) + ( 66 nil "ltvc_make_t" (:i8 :size_t)) + ( 67 nil "ltvc_make_ratio" (:i8 :size_t :t* :t*)) + ( 68 nil "ltvc_make_complex" (:i8 :size_t :t* :t*)) + ( 69 nil "ltvc_make_cons" (:i8 :size_t)) + ( 70 nil "ltvc_rplaca" (:t* :t*)) + ( 71 nil "ltvc_rplacd" (:t* :t*)) + ( 72 nil "ltvc_make_list" (:i8 :size_t :size_t)) + ( 73 nil "ltvc_fill_list" (:t* :size_t) :varargs t) + ( 74 nil "ltvc_make_array" (:i8 :size_t :t* :t*)) + ( 75 nil "ltvc_setf_row_major_aref" (:t* :size_t :t*)) + ( 76 nil "ltvc_make_hash_table" (:i8 :size_t :t*)) + ( 77 nil "ltvc_setf_gethash" (:t* :t* :t*)) + ( 78 nil "ltvc_make_fixnum" (:i8 :size_t :uintptr_t)) + ( 79 nil "ltvc_make_package" (:i8 :size_t :t*)) + ( 80 nil "ltvc_make_next_bignum" (:i8 :size_t :bignum)) + ( 81 nil "ltvc_make_bitvector" (:i8 :size_t :t*)) + ( 82 nil "ltvc_make_symbol" (:i8 :size_t :t* :t*)) + ( 83 nil "ltvc_make_character" (:i8 :size_t :uintptr_t)) + ( 84 nil "ltvc_make_base_string" (:i8 :size_t :i8*)) + ( 85 nil "ltvc_make_pathname" (:i8 :size_t :t* :t* :t* :t* :t* :t*)) + ( 86 nil "ltvc_make_function_description" (:i8 :size_t :t* :t* :t* :t* :t* :size_t + :size_t :size_t)) + ( 87 nil "ltvc_make_global_entry_point" (:i8 :size_t :size_t :t* :size_t)) + ( 88 nil "ltvc_make_local_entry_point" (:i8 :size_t :size_t :t*)) + ( 89 nil "ltvc_ensure_fcell" (:i8 :size_t :t*)) + ( 90 nil "ltvc_ensure_vcell" (:i8 :size_t :t*)) + ( 91 nil "ltvc_make_random_state" (:i8 :size_t :t*)) + ( 92 nil "ltvc_make_binary32" (:i8 :size_t :single-float)) + ( 93 nil "ltvc_make_binary64" (:i8 :size_t :double-float)) + ( 94 nil "ltvc_make_binary80" (:i8 :size_t :binary80)) + ( 95 t "ltvc_set_mlf_creator_funcall" (:i8 :size_t :size_t :i8*)) + ( 96 t "ltvc_mlf_init_funcall" (:size_t :i8*)) + ( 97 t "ltvc_mlf_init_basic_call" (:t* :size_t) :varargs t) + ( 98 t "ltvc_mlf_create_basic_call" (:i8 :size_t :t* :size_t) :varargs t) + ( 99 t "ltvc_set_ltv_funcall" (:i8 :size_t :size_t :i8*)) + (100 t "ltvc_toplevel_funcall" (:size_t :i8*)) + (102 nil "ltvc_make_binary16" (:i8 :size_t :short-float)) + (103 nil "ltvc_make_binary128" (:i8 :size_t :binary128)))) + +;;; Bytecode LTV Ops +;;; Instruction set is copied from Clasp for now. "sind" in the below means an +;;; index that the allocated object will be stored into. This may need some +;;; review later. +;;; Operations are as follows: +(defparameter +bytecode-ltv-ops+ + '((:nil 65 sind) + (:t 66 sind) + (:ratio 67) + (:complex 68) + (:cons 69 sind) + (:rplaca 70 ind1 ind2) ; (setf (car [ind1]) [ind2]) + (:rplacd 71 ind1 ind2) + (:make-array 74 sind rank . dims) + (:setf-row-major-aref 75 arrayind rmindex valueind) + (:make-hash-table 76 sind test count) + (:setf-gethash 77 htind keyind valueind) + (:make-sb64 78 sind sb64) + (:find-package 79 sind nameind) + (:make-bignum 80 sind size . words) ; size is signed + (:make-symbol 81) ; make-bitvector in clasp + (:intern 82 sind packageind nameind) ; make-symbol in clasp + (:make-character 83 sind ub32) ; ub64 in clasp, i think? + (:make-pathname 85) + (:make-bytecode-function 87) ; ltvc_make_global_entry_point + (:make-bytecode-module 88) ; ltvc_make_local_entry_point - overriding + (:setf-literals 89) ; make_random_state. compatibility is a sham here anyway + (:make-binary32 90 sind ub32) + (:make-binary64 91 sind ub64) + (:make-binary80 92 sind ub80) + (:funcall-create 93 sind find nargs . args) + (:funcall-initialize 94 find nargs . args) + (:fdefinition 95 find nameind) + (:fcell 96 find nameind) + (:vcell 97 vind nameind) + (:find-class 98 sind cnind) + ;; set-ltv-funcall in clasp- redundant + #+(or) ; obsolete as of v0.3 + (:make-specialized-array 97 sind rank dims etype . elems) + (:init-object-array 99 ub64) + (:environment 100) + (:symbol-value 101) + (:make-binary16 102 sind ub16) + (:make-binary128 103 sind ub128) + (:attribute 255 name nbytes . data))) + +(defvar +uaet-codes+ + '(:nil #b00000000 + :t #b00000001 + :base-char #b00100000 + :character #b00100001 + :binary16 #b01000000 + :binary32 #b01000001 + :binary64 #b01000010 + :binary80 #b01000011 + :binary128 #b01000111 + :complex-binary16 #b01100000 + :complex-binary32 #b01100001 + :complex-binary64 #b01100010 + :complex-binary80 #b01100011 + :complex-binary128 #b01100100 + :unsigned-byte1 #b10000000 + :unsigned-byte2 #b10000001 + :unsigned-byte4 #b10000010 + :unsigned-byte8 #b10000011 + :unsigned-byte16 #b10000100 + :unsigned-byte32 #b10000101 + :unsigned-byte64 #b10000110 + :unsigned-byte128 #b10000111 + :signed-byte8 #b10100011 + :signed-byte16 #b10100100 + :signed-byte32 #b10100101 + :signed-byte64 #b10100110 + :signed-byte128 #b10100111)) + +(defvar +debug-info-ops+ + '(:function 0 + :vars 1 + :location 2 + :decls 3 + :the 4 + :block 5 + :exit 6 + :macro 7 + :if 8 + :tagbody 9)) diff --git a/src/lisp/kernel/lsp/fli.lisp b/src/lisp/kernel/lsp/fli.lisp index a53d488bb5..0cc2719182 100644 --- a/src/lisp/kernel/lsp/fli.lisp +++ b/src/lisp/kernel/lsp/fli.lisp @@ -178,10 +178,11 @@ #+int128 :uint128 #+int128 cmp::%i128% :size cmp::%size_t% :ssize cmp::%size_t% + ;#+short-float :short-float #+short-float cmp::%short-float% :single-float cmp::%float% :float cmp::%float% :double cmp::%double% - #+long-float :long-float #+long-float cmp::%long-float% + ;#+long-float :long-float #+long-float cmp::%long-float% :pointer cmp::%i64*% :void cmp::%void% :char cmp::%i8% diff --git a/src/lisp/kernel/lsp/loadltv.lisp b/src/lisp/kernel/lsp/loadltv.lisp index f4db9ae781..22cc713c66 100644 --- a/src/lisp/kernel/lsp/loadltv.lisp +++ b/src/lisp/kernel/lsp/loadltv.lisp @@ -4,39 +4,6 @@ (in-package #:loadltv) -(defparameter +ops+ - '((nil 65 sind) - (t 66 sind) - (ratio 67) - (complex 68) - (cons 69 sind) - (rplaca 70 ind1 ind2) ; (setf (car [ind1]) [ind2]) - (rplacd 71 ind1 ind2) - (make-array 74 sind rank . dims) - (setf-row-major-aref 75 arrayind rmindex valueind) - (make-hash-table 76 sind test count) - (setf-gethash 77 htind keyind valueind) - (make-sb64 78 sind sb64) - (find-package 79 sind nameind) - (make-bignum 80 sind size . words) ; size is signed - (make-symbol 81) ; make-bitvector in clasp, but that's under arrays here - (intern 82 sind packageind nameind) ; make-symbol in clasp - (make-character 83 sind ub32) ; ub64 in clasp, i think? - (make-pathname 85) - (make-bytecode-function 87) - (make-bytecode-module 88) - (setf-literals 89 modind litsind) - (make-single-float 90 sind ub32) - (make-double-float 91 sind ub64) - (funcall-create 93 sind fnind) - (funcall-initialize 94 fnind) - (fdefinition 95 find nameind) - (find-class 98 sind cnind) - (init-object-array 99 ub64) - ;; set-ltv-funcall in clasp- redundant - (make-specialized-array 97 sind rank dims etype . elems) ; obsolete as of 0.3 - (attribute 255 name nbytes . data))) - ;;; Read an unsigned n-byte integer from a ub8 stream, big-endian. (defun read-ub (n stream) ;; read-sequence might be better but bla bla consing @@ -131,7 +98,7 @@ (defun read-mnemonic (stream) (let* ((opcode (read-byte stream)) - (info (find opcode +ops+ :key #'second))) + (info (find opcode cmpref:+bytecode-ltv-ops+ :key #'second))) (if info (first info) (error "BUG: Unknown opcode #x~x" opcode)))) @@ -212,31 +179,31 @@ Tried to define constant #~d, but it was already defined" ;; Versions 0.3-: Return value irrelevant. (defgeneric %load-instruction (mnemonic stream)) -(defmethod %load-instruction ((mnemonic (eql 'nil)) stream) +(defmethod %load-instruction ((mnemonic (eql :nil)) stream) (let ((index (read-index stream))) (dbgprint " (nil ~d)" index) (setf (constant index) nil)) *index-bytes*) -(defmethod %load-instruction ((mnemonic (eql 't)) stream) +(defmethod %load-instruction ((mnemonic (eql :t)) stream) (let ((index (read-index stream))) (dbgprint " (t ~d)" index) (setf (constant index) t)) *index-bytes*) -(defmethod %load-instruction ((mnemonic (eql 'cons)) stream) +(defmethod %load-instruction ((mnemonic (eql :cons)) stream) (let ((index (read-index stream))) (dbgprint " (cons ~d)" index) (setf (constant index) (cons nil nil))) *index-bytes*) -(defmethod %load-instruction ((mnemonic (eql 'rplaca)) stream) +(defmethod %load-instruction ((mnemonic (eql :rplaca)) stream) (let ((cons (read-index stream)) (value (read-index stream))) (dbgprint " (rplaca ~d ~d)" cons value) (setf (car (constant cons)) (constant value))) (* 2 *index-bytes*)) -(defmethod %load-instruction ((mnemonic (eql 'rplacd)) stream) +(defmethod %load-instruction ((mnemonic (eql :rplacd)) stream) (let ((cons (read-index stream)) (value (read-index stream))) (dbgprint " (rplacd ~d ~d)" cons value) (setf (cdr (constant cons)) (constant value))) @@ -266,7 +233,7 @@ Tried to define constant #~d, but it was already defined" for bits = (ldb (byte ,nbits bit-index) byte) do (setf (row-major-aref ,a (+ index j)) bits))))))) -(defmethod %load-instruction ((mnemonic (eql 'make-array)) stream) +(defmethod %load-instruction ((mnemonic (eql :make-array)) stream) (if (<= *minor* 2) (let ((index (read-index stream)) (rank (read-byte stream))) (dbgprint " (make-array ~d ~d)" index rank) @@ -330,7 +297,7 @@ Tried to define constant #~d, but it was already defined" ((equal packing-type 't)) ; setf-aref takes care of it (t (error "BUG: Unknown packing-type ~s" packing-type))))))) -(defmethod %load-instruction ((mnemonic (eql 'setf-row-major-aref)) stream) +(defmethod %load-instruction ((mnemonic (eql :setf-row-major-aref)) stream) (let ((index (read-index stream)) (aindex (read-ub16 stream)) (value (read-index stream))) (dbgprint " ((setf row-major-aref) ~d ~d ~d" index aindex value) @@ -338,7 +305,7 @@ Tried to define constant #~d, but it was already defined" (constant value))) (+ *index-bytes* 2 *index-bytes*)) -(defmethod %load-instruction ((mnemonic (eql 'make-hash-table)) stream) +(defmethod %load-instruction ((mnemonic (eql :make-hash-table)) stream) (let ((index (read-index stream))) (dbgprint " (make-hash-table ~d)" index) (let* ((testcode (read-byte stream)) @@ -352,7 +319,7 @@ Tried to define constant #~d, but it was already defined" (setf (constant index) (make-hash-table :test test :size count)))) (+ *index-bytes* 1 2)) -(defmethod %load-instruction ((mnemonic (eql 'setf-gethash)) stream) +(defmethod %load-instruction ((mnemonic (eql :setf-gethash)) stream) (let ((htind (read-index stream)) (keyind (read-index stream)) (valind (read-index stream))) (dbgprint " ((setf gethash) ~d ~d ~d)" htind keyind valind) @@ -360,19 +327,19 @@ Tried to define constant #~d, but it was already defined" (constant valind))) (+ *index-bytes* *index-bytes* *index-bytes*)) -(defmethod %load-instruction ((mnemonic (eql 'make-sb64)) stream) +(defmethod %load-instruction ((mnemonic (eql :make-sb64)) stream) (let ((index (read-index stream)) (sb64 (read-sb64 stream))) (dbgprint " (make-sb64 ~d ~d)" index sb64) (setf (constant index) sb64)) (+ *index-bytes* 8)) -(defmethod %load-instruction ((mnemonic (eql 'find-package)) stream) +(defmethod %load-instruction ((mnemonic (eql :find-package)) stream) (let ((index (read-index stream)) (name (read-index stream))) (dbgprint " (find-package ~d ~d)" index name) (setf (constant index) (find-package (constant name)))) (+ *index-bytes* *index-bytes*)) -(defmethod %load-instruction ((mnemonic (eql 'make-bignum)) stream) +(defmethod %load-instruction ((mnemonic (eql :make-bignum)) stream) (let ((index (read-index stream)) (ssize (read-sb64 stream))) (dbgprint " (make-bignum ~d ~d)" index ssize) (setf (constant index) @@ -384,19 +351,19 @@ Tried to define constant #~d, but it was already defined" finally (return (if negp (- result) result))))) (+ *index-bytes* 8 (* 8 (abs ssize))))) -(defmethod %load-instruction ((mnemonic (eql 'make-single-float)) stream) +(defmethod %load-instruction ((mnemonic (eql :make-binary32)) stream) (let ((index (read-index stream)) (bits (read-ub32 stream))) (dbgprint " (make-single-float ~d #x~4,'0x)" index bits) (setf (constant index) (ext:bits-to-single-float bits))) (+ *index-bytes* 4)) -(defmethod %load-instruction ((mnemonic (eql 'make-double-float)) stream) +(defmethod %load-instruction ((mnemonic (eql :make-binary64)) stream) (let ((index (read-index stream)) (bits (read-ub64 stream))) (dbgprint " (make-double-float ~d #x~8,'0x)" index bits) (setf (constant index) (ext:bits-to-double-float bits))) (+ *index-bytes* 8)) -(defmethod %load-instruction ((mnemonic (eql 'ratio)) stream) +(defmethod %load-instruction ((mnemonic (eql :ratio)) stream) (let ((index (read-index stream)) (numi (read-index stream)) (deni (read-index stream))) (dbgprint " (ratio ~d ~d ~d)" index numi deni) @@ -405,7 +372,7 @@ Tried to define constant #~d, but it was already defined" (/ (constant numi) (constant deni)))) (* 3 *index-bytes*)) -(defmethod %load-instruction ((mnemonic (eql 'complex)) stream) +(defmethod %load-instruction ((mnemonic (eql :complex)) stream) (let ((index (read-index stream)) (reali (read-index stream)) (imagi (read-index stream))) (dbgprint " (complex ~d ~d ~d)" index reali imagi) @@ -413,14 +380,14 @@ Tried to define constant #~d, but it was already defined" (complex (constant reali) (constant imagi)))) (* 3 *index-bytes*)) -(defmethod %load-instruction ((mnemonic (eql 'make-symbol)) stream) +(defmethod %load-instruction ((mnemonic (eql :make-symbol)) stream) (let ((index (read-index stream)) (namei (read-index stream))) (dbgprint " (make-symbol ~d ~d)" index namei) (setf (constant index) (make-symbol (constant namei)))) (+ *index-bytes* *index-bytes*)) -(defmethod %load-instruction ((mnemonic (eql 'intern)) stream) +(defmethod %load-instruction ((mnemonic (eql :intern)) stream) (let ((index (read-index stream)) (package (read-index stream)) (name (read-index stream))) (dbgprint " (intern ~d ~d ~d)" index package name) @@ -428,14 +395,14 @@ Tried to define constant #~d, but it was already defined" (intern (constant name) (constant package)))) (+ *index-bytes* *index-bytes* *index-bytes*)) -(defmethod %load-instruction ((mnemonic (eql 'make-character)) stream) +(defmethod %load-instruction ((mnemonic (eql :make-character)) stream) (let* ((index (read-index stream)) (code (read-ub32 stream)) (char (code-char code))) (dbgprint " (make-character ~d #x~x) ; ~c" index code char) (setf (constant index) char)) (+ *index-bytes* 4)) -(defmethod %load-instruction ((mnemonic (eql 'make-pathname)) stream) +(defmethod %load-instruction ((mnemonic (eql :make-pathname)) stream) (let ((index (read-index stream)) (hosti (read-index stream)) (devicei (read-index stream)) (directoryi (read-index stream)) (namei (read-index stream)) @@ -483,7 +450,7 @@ Tried to define constant #~d, but it was already defined" (defun decode-packing (code) (decode-uaet code)) ; same for now -(defmethod %load-instruction ((mnemonic (eql 'make-specialized-array)) stream) +(defmethod %load-instruction ((mnemonic (eql :make-specialized-array)) stream) (let ((index (read-index stream)) (rank (read-byte stream))) (dbgprint " (make-specialized-array ~d ~d)" index rank) @@ -506,7 +473,7 @@ Tried to define constant #~d, but it was already defined" (+ *index-bytes* 1 (* rank 2) 1 (* (ecase etype (base-char 1) (character 4)) total-size))))) -(defmethod %load-instruction ((mnemonic (eql 'make-bytecode-function)) stream) +(defmethod %load-instruction ((mnemonic (eql :make-bytecode-function)) stream) (let ((index (read-index stream)) (entry-point (read-ub32 stream)) (size (if (and (= *major* 0) (< *minor* 8)) 0 (read-ub32 stream))) @@ -541,7 +508,7 @@ Tried to define constant #~d, but it was already defined" (cmp:compile-trampoline name))))) (+ *index-bytes* 4 2 2 *index-bytes* *index-bytes* *index-bytes*)) -(defmethod %load-instruction ((mnemonic (eql 'make-bytecode-module)) stream) +(defmethod %load-instruction ((mnemonic (eql :make-bytecode-module)) stream) (let* ((index (read-index stream)) (len (read-ub32 stream)) (bytecode (make-array len :element-type '(unsigned-byte 8))) @@ -554,7 +521,7 @@ Tried to define constant #~d, but it was already defined" (core:bytecode-module/setf-literals module *constants*) (+ *index-bytes* 4 len))) -(defmethod %load-instruction ((mnemonic (eql 'setf-literals)) stream) +(defmethod %load-instruction ((mnemonic (eql :setf-literals)) stream) (if (and (= *major* 0) (<= *minor* 6)) (let ((modi (read-index stream)) (litsi (read-index stream))) (dbgprint " (setf-literals ~d ~d)" modi litsi) @@ -567,12 +534,12 @@ Tried to define constant #~d, but it was already defined" (dbgprint " (setf-literals ~s ~s)" mod lits) (core:bytecode-module/setf-literals mod lits)))) -(defmethod %load-instruction ((mnemonic (eql 'fdefinition)) stream) +(defmethod %load-instruction ((mnemonic (eql :fdefinition)) stream) (let ((find (read-index stream)) (namei (read-index stream))) (dbgprint " (fdefinition ~d ~d)" find namei) (setf (constant find) (fdefinition (constant namei))))) -(defmethod %load-instruction ((mnemonic (eql 'funcall-create)) stream) +(defmethod %load-instruction ((mnemonic (eql :funcall-create)) stream) (let ((index (read-index stream)) (funi (read-index stream)) (args (if (and (= *major* 0) (<= *minor* 4)) () @@ -583,7 +550,7 @@ Tried to define constant #~d, but it was already defined" (apply (constant funi) (mapcar #'constant args)))) (* 2 *index-bytes*)) -(defmethod %load-instruction ((mnemonic (eql 'funcall-initialize)) stream) +(defmethod %load-instruction ((mnemonic (eql :funcall-initialize)) stream) (let ((funi (read-index stream)) (args (if (and (= *major* 0) (<= *minor* 4)) () @@ -594,12 +561,12 @@ Tried to define constant #~d, but it was already defined" (apply (constant funi) (mapcar #'constant args))) *index-bytes*) -(defmethod %load-instruction ((mnemonic (eql 'find-class)) stream) +(defmethod %load-instruction ((mnemonic (eql :find-class)) stream) (let ((index (read-index stream)) (cni (read-index stream))) (dbgprint " (find-class ~d ~d)" index cni) (setf (constant index) (find-class (constant cni))))) -(defmethod %load-instruction ((mnemonic (eql 'init-object-array)) stream) +(defmethod %load-instruction ((mnemonic (eql :init-object-array)) stream) (check-initialization *initflags*) (let ((nobjs (read-ub64 stream))) (dbgprint " (init-object-array ~d)" nobjs) @@ -628,7 +595,7 @@ Tried to define constant #~d, but it was already defined" (loop repeat nbytes do (read-byte stream)))) #+clasp -(defmethod %load-attribute ((mnemonic (eql 'source-pos-info)) stream) +(defmethod %load-attribute ((mnemonic (eql :source-pos-info)) stream) ;; read and ignore nbytes. (read-ub32 stream) ;; now the actual code. @@ -652,7 +619,7 @@ Tried to define constant #~d, but it was already defined" (1 (list framei)))))))) #+clasp -(defmethod %load-attribute ((mnemonic (eql 'module-debug-info)) stream) +(defmethod %load-attribute ((mnemonic (eql :module-debug-info)) stream) (read-ub32 stream) ; ignore size (let* ((mod (constant (read-index stream))) (ncfunctions (read-ub16 stream)) @@ -672,7 +639,7 @@ Tried to define constant #~d, but it was already defined" (let ((aname (constant (read-index stream)))) (%load-attribute (or (gethash aname *attributes*) aname) stream))) -(defmethod %load-instruction ((mnemonic (eql 'attribute)) stream) +(defmethod %load-instruction ((mnemonic (eql :attribute)) stream) (load-attribute stream)) ;; TODO: Check that the FASL actually defines all of the constants. diff --git a/src/lisp/kernel/lsp/numlib.lisp b/src/lisp/kernel/lsp/numlib.lisp index 42ad69ae93..7ae200fda4 100644 --- a/src/lisp/kernel/lsp/numlib.lisp +++ b/src/lisp/kernel/lsp/numlib.lisp @@ -102,6 +102,8 @@ Returns a complex number whose realpart and imagpart are the values of (COS THETA) and (SIN THETA) respectively." (complex (cos theta) (sin theta))) +;;; this is defined in numbers.h +#+(or) (defun asin (x) "Args: (number) Returns the arc sine of NUMBER." @@ -110,20 +112,22 @@ Returns the arc sine of NUMBER." #-clasp-min (let* ((x (float x)) (xr (float x 1l0))) - (declare (long-float xr)) - (if (and (<= -1.0 xr) (<= xr 1.0)) - (float (core:num-op-asin xr) x) - (complex-asin x))))) + (declare (long-float xr)) + (if (and (<= -1.0 xr) (<= xr 1.0)) + (float (core:num-op-asin xr) x) + (complex-asin x))))) ;; Ported from CMUCL (defun complex-asin (z) (declare (number z)) (let ((sqrt-1-z (sqrt (- 1 z))) - (sqrt-1+z (sqrt (+ 1 z)))) + (sqrt-1+z (sqrt (+ 1 z)))) (complex (atan (realpart z) (realpart (* sqrt-1-z sqrt-1+z))) - (asinh (imagpart (* (conjugate sqrt-1-z) - sqrt-1+z)))))) + (asinh (imagpart (* (conjugate sqrt-1-z) + sqrt-1+z)))))) +;;; this is defined in numbers.h +#+(or) (defun acos (x) "Args: (number) Returns the arc cosine of NUMBER." diff --git a/src/lisp/kernel/lsp/predlib.lisp b/src/lisp/kernel/lsp/predlib.lisp index 3d9d41ce59..d64486570e 100644 --- a/src/lisp/kernel/lsp/predlib.lisp +++ b/src/lisp/kernel/lsp/predlib.lisp @@ -355,6 +355,8 @@ and is not adjustable." (COMPLEX-ARRAY 'COMPLEX-ARRAY-P) (CONS 'CONSP) (DOUBLE-FLOAT 'CORE:DOUBLE-FLOAT-P) + #+long-float + (LONG-FLOAT 'CORE:LONG-FLOAT-P) (FLOAT 'FLOATP) (FUNCTION 'FUNCTIONP) (HASH-TABLE 'HASH-TABLE-P) @@ -385,15 +387,17 @@ and is not adjustable." (t nil))) (defconstant-equal +upgraded-array-element-types+ - '#.(append '(NIL BASE-CHAR #+unicode CHARACTER BIT) + '#.(append '(nil base-char #+unicode character bit) '(ext:byte2 ext:integer2) '(ext:byte4 ext:integer4) - '(EXT:BYTE8 EXT:INTEGER8) - '(EXT:BYTE16 EXT:INTEGER16) - '(EXT:BYTE32 EXT:INTEGER32) + '(ext:byte8 ext:integer8) + '(ext:byte16 ext:integer16) + '(ext:byte32 ext:integer32) '(fixnum) - '(EXT:BYTE64 EXT:INTEGER64) - '(SINGLE-FLOAT DOUBLE-FLOAT T))) + '(ext:byte64 ext:integer64) + '(#+short-float short-float + #+long-float long-float + single-float double-float t))) (defun upgraded-array-element-type (element-type &optional env) (declare (ignore env)) @@ -644,10 +648,14 @@ if not possible." ((t) object) ((character base-char) (character object)) ((float) (float object)) - ((short-float) (float object 0.0s0)) - ((single-float) (float object 0.0f0)) - ((double-float) (float object 0.0d0)) - ((long-float) (float object 0.0l0)) + #+short-float + ((short-float) (core:to-short-float object)) + ((#+short-float short-float single-float) + (core:to-single-float object)) + ((double-float #-long-float long-float) + (core:to-double-float object)) + #+long-float + ((long-float) (core:to-long-float object)) ((function) (coerce-to-function object)) ((complex) (destructuring-bind (&optional (realt t) (imagt t)) @@ -1107,8 +1115,8 @@ if not possible." (RATIO (RATIO * *)) (RATIONAL (OR INTEGER RATIO)) - (FLOAT (OR SINGLE-FLOAT DOUBLE-FLOAT - #+long-float LONG-FLOAT)) + (FLOAT (OR #+short-float SHORT-FLOAT SINGLE-FLOAT + DOUBLE-FLOAT #+long-float LONG-FLOAT)) (REAL (OR INTEGER #+short-float SHORT-FLOAT SINGLE-FLOAT @@ -1149,6 +1157,10 @@ if not possible." (core:simple-vector-int32-t (simple-array ext:integer32 (*))) (core:simple-vector-int64-t (simple-array ext:integer64 (*))) (core:simple-vector-fixnum (simple-array fixnum (*))) + #+short-float + (core:simple-vector-short-float (simple-array short-float (*))) + #+long-float + (core:simple-vector-long-float (simple-array long-float (*))) (core:simple-vector-double (simple-array double-float (*))) (core:simple-vector-float (simple-array single-float (*))) (core:str8ns (complex-array base-char (*))) @@ -1167,6 +1179,10 @@ if not possible." (core:complex-vector-int32-t (complex-array ext:integer32 (*))) (core:complex-vector-int64-t (complex-array ext:integer64 (*))) (core:complex-vector-fixnum (complex-array fixnum (*))) + #+short-float + (core:complex-vector-dhort-float (complex-array short-float (*))) + #+long-float + (core:complex-vector-long-float (complex-array long-float (*))) (core:complex-vector-double (complex-array double-float (*))) (core:complex-vector-float (complex-array single-float (*))) (core:complex-vector-t (complex-array t (*))) @@ -1179,6 +1195,10 @@ if not possible." (core:MDARRAY-BYTE32-T (%complex-mdarray ext:BYTE32)) (core:MDARRAY-BYTE64-T (%complex-mdarray ext:BYTE64)) (core:MDARRAY-CHARACTER (%complex-mdarray character)) + #+short-float + (core:MDARRAY-SHORT-FLOAT (%complex-mdarray long-float)) + #+long-float + (core:MDARRAY-LONG-FLOAT (%complex-mdarray long-float)) (core:MDARRAY-DOUBLE (%complex-mdarray double-float)) (core:MDARRAY-FIXNUM (%complex-mdarray fixnum)) (core:MDARRAY-FLOAT (%complex-mdarray single-float)) @@ -1198,6 +1218,10 @@ if not possible." (core:SIMPLE-MDARRAY-BYTE32-T (%simple-mdarray ext:BYTE32)) (core:SIMPLE-MDARRAY-BYTE64-T (%simple-mdarray ext:BYTE64)) (core:SIMPLE-MDARRAY-CHARACTER (%simple-mdarray CHARACTER)) + #+short-float + (core:SIMPLE-MDARRAY-SHORT-FLOAT (%simple-mdarray SHORT-FLOAT)) + #+long-float + (core:SIMPLE-MDARRAY-LONG-FLOAT (%simple-mdarray LONG-FLOAT)) (core:SIMPLE-MDARRAY-DOUBLE (%simple-mdarray DOUBLE-FLOAT)) (core:SIMPLE-MDARRAY-FIXNUM (%simple-mdarray fixnum)) (core:SIMPLE-MDARRAY-FLOAT (%simple-mdarray SINGLE-FLOAT)) @@ -1311,61 +1335,66 @@ if not possible." (defun canonical-type (type) (declare (notinline clos::classp)) (cond ((find-registered-tag type)) - ((eq type 'T) -1) - ((eq type 'NIL) 0) + ((eq type 'T) -1) + ((eq type 'NIL) 0) ((symbolp type) - (let ((expander (ext:type-expander type))) - (cond (expander - (canonical-type (funcall expander type nil))) - ((find-built-in-tag type)) - (t (let ((class (find-class type nil))) - (if class - (progn - (register-class class)) - (progn - (throw '+canonical-type-failure+ nil)) - )))))) - ((consp type) - (case (first type) - (AND (apply #'logand (mapcar #'canonical-type (rest type)))) - (OR (apply #'logior (mapcar #'canonical-type (rest type)))) - (NOT (lognot (canonical-type (second type)))) - ((EQL MEMBER) (apply #'logior (mapcar #'register-member-type (rest type)))) - (SATISFIES (register-satisfies-type type)) - ((INTEGER SINGLE-FLOAT DOUBLE-FLOAT RATIO #+long-float LONG-FLOAT) - (register-interval-type type)) - ((FLOAT) - (canonical-type `(OR (SINGLE-FLOAT ,@(rest type)) - (DOUBLE-FLOAT ,@(rest type)) - #+long-float - (LONG-FLOAT ,@(rest type))))) - ((REAL) - (canonical-type `(OR (INTEGER ,@(rest type)) - (RATIO ,@(rest type)) - (SINGLE-FLOAT ,@(rest type)) - (DOUBLE-FLOAT ,@(rest type)) - #+long-float - (LONG-FLOAT ,@(rest type))))) - ((RATIONAL) - (canonical-type `(OR (INTEGER ,@(rest type)) - (RATIO ,@(rest type))))) - (COMPLEX - (or (find-built-in-tag type) - (canonical-complex-type (second type)))) - (CONS (apply #'register-cons-type (rest type))) - (ARRAY (logior (register-array-type `(COMPLEX-ARRAY ,@(rest type))) - (register-array-type `(SIMPLE-ARRAY ,@(rest type))))) - ((COMPLEX-ARRAY SIMPLE-ARRAY) (register-array-type type)) - (FUNCTION (canonical-type 'FUNCTION)) - (t (let ((expander (ext:type-expander (first type)))) - (if expander - (canonical-type (funcall expander type nil)) - (unless (assoc (first type) *elementary-types*) - (throw '+canonical-type-failure+ nil))))))) - ((clos::classp type) - (register-class type)) - (t - (error-type-specifier type)))) + (let ((expander (ext:type-expander type))) + (cond (expander + (canonical-type (funcall expander type nil))) + ((find-built-in-tag type)) + (t (let ((class (find-class type nil))) + (if class + (progn + (register-class class)) + (progn + (throw '+canonical-type-failure+ nil)) + )))))) + ((consp type) + (case (first type) + (AND (apply #'logand (mapcar #'canonical-type (rest type)))) + (OR (apply #'logior (mapcar #'canonical-type (rest type)))) + (NOT (lognot (canonical-type (second type)))) + ((EQL MEMBER) (apply #'logior (mapcar #'register-member-type (rest type)))) + (SATISFIES (register-satisfies-type type)) + ((INTEGER #+short-float SHORT-FLOAT SINGLE-FLOAT + DOUBLE-FLOAT RATIO #+long-float LONG-FLOAT) + (register-interval-type type)) + ((FLOAT) + (canonical-type `(OR #+short-float + (SHORT-FLOAT ,@(rest type)) + (SINGLE-FLOAT ,@(rest type)) + (DOUBLE-FLOAT ,@(rest type)) + #+long-float + (LONG-FLOAT ,@(rest type))))) + ((REAL) + (canonical-type `(OR (INTEGER ,@(rest type)) + (RATIO ,@(rest type)) + #+short-float + (SHORT-FLOAT ,@(rest type)) + (SINGLE-FLOAT ,@(rest type)) + (DOUBLE-FLOAT ,@(rest type)) + #+long-float + (LONG-FLOAT ,@(rest type))))) + ((RATIONAL) + (canonical-type `(OR (INTEGER ,@(rest type)) + (RATIO ,@(rest type))))) + (COMPLEX + (or (find-built-in-tag type) + (canonical-complex-type (second type)))) + (CONS (apply #'register-cons-type (rest type))) + (ARRAY (logior (register-array-type `(COMPLEX-ARRAY ,@(rest type))) + (register-array-type `(SIMPLE-ARRAY ,@(rest type))))) + ((COMPLEX-ARRAY SIMPLE-ARRAY) (register-array-type type)) + (FUNCTION (canonical-type 'FUNCTION)) + (t (let ((expander (ext:type-expander (first type)))) + (if expander + (canonical-type (funcall expander type nil)) + (unless (assoc (first type) *elementary-types*) + (throw '+canonical-type-failure+ nil))))))) + ((clos::classp type) + (register-class type)) + (t + (error-type-specifier type)))) (defun safe-canonical-type (type) (catch '+canonical-type-failure+ diff --git a/src/lisp/regression-tests/read01.lisp b/src/lisp/regression-tests/read01.lisp index 345296ef04..03740e0088 100644 --- a/src/lisp/regression-tests/read01.lisp +++ b/src/lisp/regression-tests/read01.lisp @@ -10,7 +10,7 @@ (dolist (type (list 'short-float 'single-float 'double-float 'long-float) (reverse result)) (let ((*read-default-float-format* type)) (push (read-from-string "1.111") result)))) - ((1.111 1.111 1.111d0 1.111d0))) + ((1.111s0 1.111f0 1.111d0 1.111l0))) (test read-2 (ext:with-float-traps-masked (:invalid :overflow :underflow :divide-by-zero) diff --git a/src/llvmo/link_intrinsics.cc b/src/llvmo/link_intrinsics.cc index 27e830d569..0f89fcf506 100644 --- a/src/llvmo/link_intrinsics.cc +++ b/src/llvmo/link_intrinsics.cc @@ -419,16 +419,37 @@ LtvcReturnVoid ltvc_make_random_state(gctools::GCRootsInModule* holder, char tag NO_UNWIND_END(); } -LtvcReturnVoid ltvc_make_float(gctools::GCRootsInModule* holder, char tag, size_t index, float f) { +LtvcReturnVoid ltvc_make_binary16(gctools::GCRootsInModule* holder, char tag, size_t index, core::short_float_t f) { NO_UNWIND_BEGIN(); core::T_sp val = clasp_make_single_float(f); LTVCRETURN holder->setTaggedIndex(tag, index, val.tagged_()); NO_UNWIND_END(); } -LtvcReturnVoid ltvc_make_double(gctools::GCRootsInModule* holder, char tag, size_t index, double f) { +LtvcReturnVoid ltvc_make_binary32(gctools::GCRootsInModule* holder, char tag, size_t index, core::single_float_t f) { NO_UNWIND_BEGIN(); - core::T_sp val = clasp_make_double_float(f); + core::T_sp val = clasp_make_single_float(f); + LTVCRETURN holder->setTaggedIndex(tag, index, val.tagged_()); + NO_UNWIND_END(); +} + +LtvcReturnVoid ltvc_make_binary64(gctools::GCRootsInModule* holder, char tag, size_t index, core::double_float_t f) { + NO_UNWIND_BEGIN(); + core::T_sp val = DoubleFloat_O::create(f); + LTVCRETURN holder->setTaggedIndex(tag, index, val.tagged_()); + NO_UNWIND_END(); +} + +LtvcReturnVoid ltvc_make_binary80(gctools::GCRootsInModule* holder, char tag, size_t index, core::long_float_t f) { + NO_UNWIND_BEGIN(); + core::T_sp val = LongFloat_O::create(f); + LTVCRETURN holder->setTaggedIndex(tag, index, val.tagged_()); + NO_UNWIND_END(); +} + +LtvcReturnVoid ltvc_make_binary128(gctools::GCRootsInModule* holder, char tag, size_t index, core::long_float_t f) { + NO_UNWIND_BEGIN(); + core::T_sp val = LongFloat_O::create(f); LTVCRETURN holder->setTaggedIndex(tag, index, val.tagged_()); NO_UNWIND_END(); } diff --git a/src/llvmo/llvmoExpose.cc b/src/llvmo/llvmoExpose.cc index 9e17ab84e8..6663262ef3 100644 --- a/src/llvmo/llvmoExpose.cc +++ b/src/llvmo/llvmoExpose.cc @@ -3460,10 +3460,18 @@ CL_EXTERN_DEFMETHOD(Type_O, &llvm::Type::getScalarType); CL_LISPIFY_NAME("type-get-void-ty"); CL_EXTERN_DEFUN((llvm::Type * (*)(llvm::LLVMContext & C)) & llvm::Type::getVoidTy); +CL_LISPIFY_NAME("type-get-half-ty"); +CL_EXTERN_DEFUN((llvm::Type * (*)(llvm::LLVMContext & C)) & llvm::Type::getHalfTy); +CL_LISPIFY_NAME("type-get-bfloat-ty"); +CL_EXTERN_DEFUN((llvm::Type * (*)(llvm::LLVMContext & C)) & llvm::Type::getBFloatTy); CL_LISPIFY_NAME("type-get-float-ty"); CL_EXTERN_DEFUN((llvm::Type * (*)(llvm::LLVMContext & C)) & llvm::Type::getFloatTy); CL_LISPIFY_NAME("type-get-double-ty"); CL_EXTERN_DEFUN((llvm::Type * (*)(llvm::LLVMContext & C)) & llvm::Type::getDoubleTy); +CL_LISPIFY_NAME("type-get-x86-fp80-ty"); +CL_EXTERN_DEFUN((llvm::Type * (*)(llvm::LLVMContext & C)) & llvm::Type::getX86_FP80Ty); +CL_LISPIFY_NAME("type-get-fp128-ty"); +CL_EXTERN_DEFUN((llvm::Type * (*)(llvm::LLVMContext & C)) & llvm::Type::getFP128Ty); CL_LISPIFY_NAME("type-get-metadata-ty"); CL_EXTERN_DEFUN((llvm::Type * (*)(llvm::LLVMContext & C)) & llvm::Type::getMetadataTy); diff --git a/src/scraper/parse.lisp b/src/scraper/parse.lisp index f97463d490..5fde4f4af9 100644 --- a/src/scraper/parse.lisp +++ b/src/scraper/parse.lisp @@ -327,7 +327,7 @@ CL call to (core:magic-intern ...)" (esrap:defrule whitespace (+ (or #\space #\tab #\newline)) (:constant nil)) -(esrap:defrule alphanumeric (or ":" (alphanumericp character))) +(esrap:defrule alphanumeric (or ":" "_" (alphanumericp character))) (esrap:defrule cidentifier (not-integer (+ alphanumeric)) (:lambda (s) diff --git a/tools-for-build/ansi-test-expected-failures.sexp b/tools-for-build/ansi-test-expected-failures.sexp index 874823ac2a..c9dbc69bc6 100644 --- a/tools-for-build/ansi-test-expected-failures.sexp +++ b/tools-for-build/ansi-test-expected-failures.sexp @@ -14,6 +14,8 @@ :MAKE-CONDITION-WITH-COMPOUND-NAME :NO-FLOATING-POINT-UNDERFLOW-BY-DEFAULT +PRINT.LONG-FLOAT.RANDOM + ;;; These aren't true failures. They only happen because we use LOAD. LOAD-PATHNAME.1 LOAD-TRUENAME.1