Use Incless, Inravina and Invistra as the printer stack

include/clasp/core/core.h

@@ -51,24 +51,31 @@ namespace core {
 #ifdef USE_SHORT_FLOAT
 #define CLASP_SHORT_FLOAT
 #define CLASP_SHORT_FLOAT_BINARY16
+#define SYM_SHORT_FLOAT_IMPL cl::_sym_short_float
 typedef _Float16 short_float_t;
 #else
+#define SYM_SHORT_FLOAT_IMPL cl::_sym_single_float
 typedef float short_float_t;
 #endif
 
+#define SYM_SINGLE_FLOAT_IMPL cl::_sym_single_float
 typedef float single_float_t;
 
+#define SYM_DOUBLE_FLOAT_IMPL cl::_sym_double_float
 typedef double double_float_t;
 
 #if defined(USE_LONG_FLOAT) && LDBL_MANT_DIG == 64
 #define CLASP_LONG_FLOAT
 #define CLASP_LONG_FLOAT_BINARY80
+#define SYM_LONG_FLOAT_IMPL cl::_sym_long_float
 typedef long double long_float_t;
 #elif defined(USE_LONG_FLOAT) && LDBL_MANT_DIG == 113
 #define CLASP_LONG_FLOAT
 #define CLASP_LONG_FLOAT_BINARY128
+#define SYM_LONG_FLOAT_IMPL cl::_sym_long_float
 typedef long double long_float_t;
 #else
+#define SYM_LONG_FLOAT_IMPL cl::_sym_double_float
 typedef double long_float_t;
 #endif
 };

include/clasp/core/float_util.h

@@ -20,6 +20,7 @@ template <uint16_t ExponentWidth, uint16_t SignificandWidth> struct float_traits
                                             std::conditional_t<storage_width <= 32, uint32_t,
                                                                std::conditional_t<storage_width <= 64, uint64_t, __uint128_t>>>>;
   static constexpr uint_t hidden_bit = has_hidden_bit ? uint_t{1} << (significand_width - 1) : uint_t{0};
+  static constexpr uint_t non_hidden_bit = (!has_hidden_bit) ? uint_t{1} << (significand_width - 1) : uint_t{0};
   static constexpr uint16_t exponent_shift = storage_width - sign_width - exponent_width;
   static constexpr uint16_t sign_shift = storage_width - sign_width;
   static constexpr uint_t significand_mask = (uint_t{1} << (significand_width + ((has_hidden_bit) ? -1 : 0))) - uint_t{1};
@@ -78,7 +79,7 @@ template <typename Float> struct float_convert {
         q.significand = q.significand << shift;
         q.exponent = 1 - Traits::exponent_bias - shift;
       }
-    } else if (q.significand == 0) {
+    } else if (q.significand == Traits::non_hidden_bit) {
       q.category = category::infinity;
     } else if (q.significand & Traits::nan_type_mask) {
       q.category = category::quiet_nan;
@@ -99,7 +100,7 @@ template <typename Float> struct float_convert {
 
     switch (q.category) {
     case category::infinity:
-      b |= Traits::exponent_mask;
+      b |= Traits::exponent_mask | Traits::non_hidden_bit;
       break;
     case category::quiet_nan:
       b |= Traits::exponent_mask | Traits::nan_type_mask | (q.significand & Traits::payload_mask);
@@ -149,7 +150,7 @@ template <typename Float> struct float_convert {
         if (exponent > Traits::max_exponent) {
           feraiseexcept(FE_OVERFLOW);
           // Return +/- infinity if traps masked.
-          return b | Traits::exponent_mask;
+          return b | Traits::exponent_mask | Traits::non_hidden_bit;
         }
 
         if (std::bit_width(significand) < Traits::significand_width) {

repos.sexp

@@ -206,21 +206,18 @@
  (:name :incless
   :directory "src/lisp/kernel/contrib/Incless/"
   :repository "https://github.com/s-expressionists/Incless.git"
-  :branch "main"
-  :commit "3a8ace620f1042a54ecbba04a05c816e89aa8eab"
-  :pin 1)
+  :branch "host"
+  :pin o)
  (:name :inravina
   :directory "src/lisp/kernel/contrib/Inravina/"
   :repository "https://github.com/s-expressionists/Inravina.git"
-  :branch "main"
-  :commit "a1c98c87efee5a8b5d244d116a8520981c252fff"
-  :pin 1)
+  :branch "host"
+  :pin 0)
  (:name :invistra
   :directory "src/lisp/kernel/contrib/Invistra/"
   :repository "https://github.com/s-expressionists/Invistra.git"
-  :branch "main"
-  :commit "33758cc91db36ebec46df51da7235ffcf2482b0b"
-  :pin 1)
+  :branch "alt-parse-3"
+  :pin 0)
  (:name :khazern
   :directory "src/lisp/kernel/contrib/Khazern/"
   :repository "https://github.com/s-expressionists/Khazern.git"
@@ -270,9 +267,8 @@
  (:name :nontrivial-gray-streams
   :directory "src/lisp/kernel/contrib/nontrivial-gray-streams/"
   :repository "https://github.com/yitzchak/nontrivial-gray-streams.git"
-  :branch "main"
-  :commit "0f7ba9e3018eafe03c521961183a126a2a9c0c4f"
-  :pin 1)
+  :branch "host"
+  :pin 0)
  (:name :parser.common-rules
   :extension :cando
   :directory "src/lisp/kernel/contrib/parser.common-rules/"
@@ -295,11 +291,10 @@
   :commit "47a70ba1e32362e03dad6ef8e6f36180b560f86a"
   :pin 1)
  (:name :quaviver
-  :directory "src/lisp/kernel/contrib/quaviver/"
-  :repository "https://github.com/s-expressionists/quaviver.git"
-  :branch "main"
-  :commit "6d0ee719fef9dca72b4da8dd48d99c66feb317f3"
-  :pin 1)
+  :directory "src/lisp/kernel/contrib/Quaviver/"
+  :repository "https://github.com/s-expressionists/Quaviver.git"
+  :branch "host"
+  :pin 0)
  (:name :quicklisp-client
   :directory "dependencies/quicklisp-client/"
   :repository "https://github.com/quicklisp/quicklisp-client.git"
@@ -422,4 +417,4 @@
   :repository "https://github.com/usocket/usocket.git"
   :branch "master"
   :commit "32f4841b4313d37c36963d0d1865135ee4e29a01"
-  :pin 1))
+  :pin 1))

src/core/bignum.cc

@@ -836,9 +836,9 @@ template <typename Float> Float limbs_to_float(mp_size_t len, const mp_limb_t* l
 
 short_float_t Bignum_O::as_short_float_() const { return limbs_to_float<short_float_t>(this->length(), this->limbs()); }
 
-single_float_t Bignum_O::as_single_float_() const { return limbs_to_float<float>(this->length(), this->limbs()); }
+single_float_t Bignum_O::as_single_float_() const { return limbs_to_float<single_float_t>(this->length(), this->limbs()); }
 
-double_float_t Bignum_O::as_double_float_() const { return limbs_to_float<double>(this->length(), this->limbs()); }
+double_float_t Bignum_O::as_double_float_() const { return limbs_to_float<double_float_t>(this->length(), this->limbs()); }
 
 long_float_t Bignum_O::as_long_float_() const { return limbs_to_float<long_float_t>(this->length(), this->limbs()); }
 

src/core/commonLispPackage.cc

@@ -126,6 +126,7 @@ SYMBOL_EXPORT_SC_(ClPkg, character);
 SYMBOL_EXPORT_SC_(ClPkg, characterp);
 SYMBOL_EXPORT_SC_(ClPkg, class);
 SYMBOL_EXPORT_SC_(ClPkg, class_name);
+SYMBOL_EXPORT_SC_(ClPkg, close);
 SYMBOL_EXPORT_SC_(ClPkg, compilation_speed);
 SYMBOL_EXPORT_SC_(ClPkg, compile);
 SYMBOL_EXPORT_SC_(ClPkg, compileFile);
@@ -310,6 +311,7 @@ SYMBOL_EXPORT_SC_(ClPkg, stream);
 SYMBOL_EXPORT_SC_(ClPkg, streamError);
 SYMBOL_EXPORT_SC_(ClPkg, stream_element_type);
 SYMBOL_EXPORT_SC_(ClPkg, stream_external_format);
+SYMBOL_EXPORT_SC_(ClPkg, streamp);
 SYMBOL_EXPORT_SC_(ClPkg, string);
 SYMBOL_EXPORT_SC_(ClPkg, stringp);
 SYMBOL_EXPORT_SC_(ClPkg, structure_object);

src/core/corePackage.cc

@@ -274,6 +274,8 @@ SYMBOL_EXPORT_SC_(CorePkg, unquote_nsplice);
 SYMBOL_EXPORT_SC_(CorePkg, unquote_splice);
 SYMBOL_EXPORT_SC_(CorePkg, valist);
 SYMBOL_EXPORT_SC_(CorePkg, wrongNumberOfArguments);
+SYMBOL_SC_(CorePkg, PERCENTwrite_object);
+SYMBOL_SC_(CorePkg, PERCENTcircle_check);
 SYMBOL_SC_(CorePkg, DOT);
 SYMBOL_SC_(CorePkg, STARPATHSTAR);
 SYMBOL_SC_(CorePkg, STARargsSTAR);

src/core/debugger2.cc

@@ -234,8 +234,11 @@ struct DebuggerLevelRAII {
 };
 
 T_mv early_debug(T_sp condition, bool can_continue) {
+  if (condition.notnilp()) {
+    clasp_write_string(fmt::format("Debugger entered with condition: {}\n", _rep_(condition)));
+  }
   if (!isatty(0)) {
-    printf("The low-level debugger was entered but there is no terminal on fd0 - aboring\n");
+    printf("The low-level debugger was entered but there is no terminal on fd0 - aborting\n");
     abort();
   }
   if (global_options->_DebuggerDisabled) {
@@ -246,14 +249,14 @@ T_mv early_debug(T_sp condition, bool can_continue) {
   if (globals_->_DebuggerLevel > 10) {
     printf("The low-level debugger was recursively entered too many times - exiting\n");
   }
-  if (condition.notnilp()) {
-    clasp_write_string(fmt::format("Debugger entered with condition: {}\n", _rep_(condition)));
-  }
   DynamicScopeManager scope(core::_sym_STARdebugConditionSTAR, condition);
   return call_with_frame([=](auto frame) { return early_debug_inner(frame, can_continue); });
 }
 
 DOCGROUP(clasp);
 CL_DEFUN T_mv core__early_debug(T_sp condition) { return early_debug(condition, true); }
 
+DOCGROUP(clasp);
+CL_DEFUN T_mv cl__invoke_debugger(T_sp condition) { return early_debug(condition, true); }
+
 }; // namespace core

src/core/float_to_digits.cc

@@ -110,4 +110,35 @@ CL_DEFUN T_mv core__float_to_digits(T_sp tdigits, Float_sp number, T_sp position
 
 SYMBOL_EXPORT_SC_(CorePkg, float_to_digits);
 
+CL_DEFUN List_sp core__float_traits() {
+  return Cons_O::createList(
+      Cons_O::create(
+          cl::_sym_short_float,
+          Cons_O::createList(
+              Cons_O::create(kw::_sym_exponent_size, clasp_make_fixnum(schubfach::float_traits<short_float_t>::exponent_width)),
+              Cons_O::create(kw::_sym_significand_size,
+                             clasp_make_fixnum(schubfach::float_traits<short_float_t>::significand_width)),
+              Cons_O::create(kw::_sym_implementation_type, SYM_SHORT_FLOAT_IMPL))),
+      Cons_O::create(
+          cl::_sym_single_float,
+          Cons_O::createList(
+              Cons_O::create(kw::_sym_exponent_size, clasp_make_fixnum(schubfach::float_traits<single_float_t>::exponent_width)),
+              Cons_O::create(kw::_sym_significand_size,
+                             clasp_make_fixnum(schubfach::float_traits<single_float_t>::significand_width)),
+              Cons_O::create(kw::_sym_implementation_type, SYM_SINGLE_FLOAT_IMPL))),
+      Cons_O::create(
+          cl::_sym_double_float,
+          Cons_O::createList(
+              Cons_O::create(kw::_sym_exponent_size, clasp_make_fixnum(schubfach::float_traits<double_float_t>::exponent_width)),
+              Cons_O::create(kw::_sym_significand_size,
+                             clasp_make_fixnum(schubfach::float_traits<double_float_t>::significand_width)),
+              Cons_O::create(kw::_sym_implementation_type, SYM_DOUBLE_FLOAT_IMPL))),
+      Cons_O::create(cl::_sym_long_float,
+                     Cons_O::createList(Cons_O::create(kw::_sym_exponent_size,
+                                                       clasp_make_fixnum(schubfach::float_traits<long_float_t>::exponent_width)),
+                                        Cons_O::create(kw::_sym_significand_size,
+                                                       clasp_make_fixnum(schubfach::float_traits<long_float_t>::significand_width)),
+                                        Cons_O::create(kw::_sym_implementation_type, SYM_LONG_FLOAT_IMPL))));
+}
+
 }; // namespace core

src/core/grayPackage.cc

@@ -65,15 +65,7 @@ SYMBOL_EXPORT_SC_(GrayPkg, stream_write_byte);
 SYMBOL_EXPORT_SC_(GrayPkg, stream_write_char);
 SYMBOL_EXPORT_SC_(GrayPkg, stream_write_sequence);
 SYMBOL_EXPORT_SC_(GrayPkg, stream_write_string);
-SYMBOL_SHADOW_EXPORT_SC_(GrayPkg, close);
-SYMBOL_SHADOW_EXPORT_SC_(GrayPkg, input_stream_p);
-SYMBOL_SHADOW_EXPORT_SC_(GrayPkg, open_stream_p);
-SYMBOL_SHADOW_EXPORT_SC_(GrayPkg, output_stream_p);
-SYMBOL_SHADOW_EXPORT_SC_(GrayPkg, pathname);
-SYMBOL_SHADOW_EXPORT_SC_(GrayPkg, stream_element_type);
-SYMBOL_SHADOW_EXPORT_SC_(GrayPkg, stream_external_format);
 SYMBOL_SHADOW_EXPORT_SC_(GrayPkg, streamp);
-SYMBOL_SHADOW_EXPORT_SC_(GrayPkg, truename);
 
 void initialize_grayPackage() {
   list<string> lnicknames;

src/core/keywordPackage.cc

@@ -36,6 +36,9 @@ THE SOFTWARE.
 
 namespace kw {
 
+SYMBOL_EXPORT_SC_(KeywordPkg, significand_size);
+SYMBOL_EXPORT_SC_(KeywordPkg, exponent_size);
+SYMBOL_EXPORT_SC_(KeywordPkg, implementation_type);
 SYMBOL_EXPORT_SC_(KeywordPkg, FullDebug);
 SYMBOL_EXPORT_SC_(KeywordPkg, LineTablesOnly);
 SYMBOL_EXPORT_SC_(KeywordPkg, UnsignedByte);

src/core/lispStream.cc

@@ -251,7 +251,7 @@ T_sp stream_open(T_sp fn, StreamDirection direction, StreamIfExists if_exists, S
 CL_LISPIFY_NAME("gray:%close")
 CL_DEFUN T_sp stream_close(T_sp stream, T_sp abort) {
   return stream.isA<AnsiStream_O>() ? stream.as_unsafe<AnsiStream_O>()->close(abort)
-                                    : eval::funcall(gray::_sym_close, stream, kw::_sym_abort, abort);
+                                    : eval::funcall(cl::_sym_close, stream, kw::_sym_abort, abort);
 }
 
 // Low level byte functions
@@ -469,7 +469,7 @@ void stream_write_sequence(T_sp stream, T_sp data, cl_index start, cl_index end)
 CL_LISPIFY_NAME("gray:%open-stream-p")
 CL_DEFUN bool stream_open_p(T_sp stream) {
   return stream.isA<AnsiStream_O>() ? stream.as_unsafe<AnsiStream_O>()->open_p()
-                                    : T_sp(eval::funcall(gray::_sym_open_stream_p, stream)).notnilp();
+                                    : T_sp(eval::funcall(cl::_sym_open_stream_p, stream)).notnilp();
 }
 
 bool stream_p(T_sp stream) {
@@ -479,7 +479,7 @@ bool stream_p(T_sp stream) {
 CL_LISPIFY_NAME("gray:%input-stream-p")
 CL_DEFUN bool stream_input_p(T_sp stream) {
   return stream.isA<AnsiStream_O>() ? stream.as_unsafe<AnsiStream_O>()->input_p()
-                                    : T_sp(eval::funcall(gray::_sym_input_stream_p, stream)).notnilp();
+                                    : T_sp(eval::funcall(cl::_sym_input_stream_p, stream)).notnilp();
 }
 
 // This function is exposed to CL because it is needed to implement
@@ -488,7 +488,7 @@ CL_DEFUN bool stream_input_p(T_sp stream) {
 CL_LISPIFY_NAME("gray:%output-stream-p")
 CL_DEFUN bool stream_output_p(T_sp stream) {
   return stream.isA<AnsiStream_O>() ? stream.as_unsafe<AnsiStream_O>()->output_p()
-                                    : T_sp(eval::funcall(gray::_sym_output_stream_p, stream)).notnilp();
+                                    : T_sp(eval::funcall(cl::_sym_output_stream_p, stream)).notnilp();
 }
 
 // This function is exposed to CL because it is needed to implement
@@ -508,7 +508,7 @@ CL_DEFUN bool stream_interactive_p(T_sp stream) {
 CL_LISPIFY_NAME("gray:%stream-element-type")
 CL_DEFUN T_sp stream_element_type(T_sp stream) {
   return stream.isA<AnsiStream_O>() ? stream.as_unsafe<AnsiStream_O>()->element_type()
-                                    : eval::funcall(gray::_sym_stream_element_type, stream);
+                                    : eval::funcall(cl::_sym_stream_element_type, stream);
 }
 
 // This function is exposed to CL because it is needed to implement
@@ -650,11 +650,11 @@ void stream_restore_input_cursor(T_sp stream) {
 // Stream pathname functions
 
 T_sp stream_pathname(T_sp stream) {
-  return stream.isA<AnsiStream_O>() ? stream.as_unsafe<AnsiStream_O>()->pathname() : eval::funcall(gray::_sym_pathname, stream);
+  return stream.isA<AnsiStream_O>() ? stream.as_unsafe<AnsiStream_O>()->pathname() : eval::funcall(cl::_sym_pathname, stream);
 }
 
 T_sp stream_truename(T_sp stream) {
-  return stream.isA<AnsiStream_O>() ? stream.as_unsafe<AnsiStream_O>()->truename() : eval::funcall(gray::_sym_truename, stream);
+  return stream.isA<AnsiStream_O>() ? stream.as_unsafe<AnsiStream_O>()->truename() : eval::funcall(cl::_sym_truename, stream);
 }
 
 // Stream file descriptor functions

src/core/write_object.cc

@@ -49,6 +49,8 @@ THE SOFTWARE.
 namespace core {
 
 bool will_print_as_hash(T_sp x) {
+  if (core::_sym_PERCENTcircle_check->fboundp())
+    return ((T_sp)core::eval::funcall(core::_sym_PERCENTcircle_check, x)).notnilp();
   T_sp circle_counter = _sym_STARcircle_counterSTAR->symbolValue();
   HashTable_sp circle_stack = gc::As<HashTable_sp>(_sym_STARcircle_stackSTAR->symbolValue());
   T_sp code = circle_stack->gethash(x, unbound<T_O>());
@@ -141,7 +143,8 @@ T_sp do_write_object_circle(T_sp x, T_sp stream) {
 }
 
 T_sp write_object(T_sp x, T_sp stream) {
-  // With *print-pretty*, go immediately to the pretty printer, which does its own *print-circle* etc.
+  if (core::_sym_PERCENTwrite_object->fboundp())
+    return core::eval::funcall(core::_sym_PERCENTwrite_object, x, stream);
   if (!cl::_sym_STARprint_prettySTAR.unboundp() && cl::_sym_STARprint_prettySTAR->boundP() &&
       cl::_sym_STARprint_prettySTAR->symbolValue().notnilp()) {
     T_mv mv_f = eval::funcall(cl::_sym_pprint_dispatch, x);