diff --git a/include/clasp/core/core.h b/include/clasp/core/core.h index 9438bde5e6..33569ca8f8 100644 --- a/include/clasp/core/core.h +++ b/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 }; diff --git a/include/clasp/core/float_util.h b/include/clasp/core/float_util.h index 524fef3a77..2bd2762b2b 100644 --- a/include/clasp/core/float_util.h +++ b/include/clasp/core/float_util.h @@ -20,6 +20,7 @@ template struct float_traits std::conditional_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 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 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 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) { diff --git a/repos.sexp b/repos.sexp index 5f64ede20e..6028d32470 100644 --- a/repos.sexp +++ b/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)) \ No newline at end of file + :pin 1)) diff --git a/src/core/bignum.cc b/src/core/bignum.cc index 2a22c8671e..3b678d2996 100644 --- a/src/core/bignum.cc +++ b/src/core/bignum.cc @@ -836,9 +836,9 @@ template 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(this->length(), this->limbs()); } -single_float_t Bignum_O::as_single_float_() 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()); } -double_float_t Bignum_O::as_double_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()); } diff --git a/src/core/commonLispPackage.cc b/src/core/commonLispPackage.cc index 660d093fb3..fbabc81336 100644 --- a/src/core/commonLispPackage.cc +++ b/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); diff --git a/src/core/corePackage.cc b/src/core/corePackage.cc index 61e5e681ae..c8b88692bd 100644 --- a/src/core/corePackage.cc +++ b/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); diff --git a/src/core/debugger2.cc b/src/core/debugger2.cc index 82a3e83255..8aa2217a8d 100644 --- a/src/core/debugger2.cc +++ b/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,9 +249,6 @@ 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); }); } @@ -256,4 +256,7 @@ T_mv early_debug(T_sp condition, bool 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 diff --git a/src/core/float_to_digits.cc b/src/core/float_to_digits.cc index 84e5fb080b..19dc0fd464 100644 --- a/src/core/float_to_digits.cc +++ b/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::exponent_width)), + Cons_O::create(kw::_sym_significand_size, + clasp_make_fixnum(schubfach::float_traits::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::exponent_width)), + Cons_O::create(kw::_sym_significand_size, + clasp_make_fixnum(schubfach::float_traits::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::exponent_width)), + Cons_O::create(kw::_sym_significand_size, + clasp_make_fixnum(schubfach::float_traits::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::exponent_width)), + Cons_O::create(kw::_sym_significand_size, + clasp_make_fixnum(schubfach::float_traits::significand_width)), + Cons_O::create(kw::_sym_implementation_type, SYM_LONG_FLOAT_IMPL)))); +} + }; // namespace core diff --git a/src/core/grayPackage.cc b/src/core/grayPackage.cc index 23d2e3ab4f..4a42cc6b98 100644 --- a/src/core/grayPackage.cc +++ b/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 lnicknames; diff --git a/src/core/keywordPackage.cc b/src/core/keywordPackage.cc index 9f653ee402..7451e53ead 100644 --- a/src/core/keywordPackage.cc +++ b/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); diff --git a/src/core/lispStream.cc b/src/core/lispStream.cc index f86d9b9834..7c85c93e2e 100644 --- a/src/core/lispStream.cc +++ b/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() ? stream.as_unsafe()->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() ? stream.as_unsafe()->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() ? stream.as_unsafe()->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() ? stream.as_unsafe()->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() ? stream.as_unsafe()->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() ? stream.as_unsafe()->pathname() : eval::funcall(gray::_sym_pathname, stream); + return stream.isA() ? stream.as_unsafe()->pathname() : eval::funcall(cl::_sym_pathname, stream); } T_sp stream_truename(T_sp stream) { - return stream.isA() ? stream.as_unsafe()->truename() : eval::funcall(gray::_sym_truename, stream); + return stream.isA() ? stream.as_unsafe()->truename() : eval::funcall(cl::_sym_truename, stream); } // Stream file descriptor functions diff --git a/src/core/write_object.cc b/src/core/write_object.cc index 1a9bb2fcee..22d7a43ee7 100644 --- a/src/core/write_object.cc +++ b/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(_sym_STARcircle_stackSTAR->symbolValue()); T_sp code = circle_stack->gethash(x, unbound()); @@ -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); diff --git a/src/cross-clasp/base.lisp b/src/cross-clasp/base.lisp index 2ee9b7f3f6..fed6a4f0b0 100644 --- a/src/cross-clasp/base.lisp +++ b/src/cross-clasp/base.lisp @@ -62,8 +62,9 @@ ;; use trivial-package-local-nicknames, but resolve names in the ;; cross-clasp environment. -(defun ext:add-package-local-nickname (local-nickname actual-package - &optional (package (m:symbol-value m:*client* *build-rte* '*package*))) +(defun ext:add-package-local-nickname + (local-nickname actual-package + &optional (package (m:symbol-value m:*client* *build-rte* '*package*))) (let ((actual-package (if (packagep actual-package) actual-package @@ -91,10 +92,21 @@ plist) (defparameter *shared-package-names* - '("ALEXANDRIA" "ECCLESIA" "KHAZERN" - "ECLECTOR.BASE" "ECLECTOR.READER" - "ECLECTOR.READTABLE" "ECLECTOR.READTABLE.SIMPLE" + '("ALEXANDRIA" + "ECCLESIA" + "ECLECTOR.BASE" "ECLECTOR.PARSE-RESULT" + "ECLECTOR.READER" + "ECLECTOR.READTABLE" + "ECLECTOR.READTABLE.SIMPLE" + "INCLESS" + "INRAVINA" + "INVISTRA" + "KHAZERN" + "QUAVIVER" + "QUAVIVER.CONDITION" + "QUAVIVER.MATH" + "QUAVIVER/SCHUBFACH" "TRIVIAL-WITH-CURRENT-SOURCE-FORM")) ;;; make a package in the build environment. @@ -120,7 +132,8 @@ (error "Tried to use undefined package ~s" s)))) (package (or (find-package hname) (if sharedp - (error "BUG: Package ~a should exist in the host already but doesn't" hname) + (error "BUG: Package ~a should exist in the host already but doesn't" + hname) (make-package hname :use use))))) (setf (clostrum:package-name m:*client* *build-rte* package) name (clostrum:find-package m:*client* *build-rte* name) package) @@ -215,6 +228,7 @@ `(let ((package (find-package ',hostname))) (setf (clostrum:package-name client environment package) ,name (clostrum:find-package client environment ,name) package + (clostrum:find-package client environment ,(string hostname)) package ,@(loop for nick in nicknames collect `(clostrum:find-package client environment ,nick) @@ -239,7 +253,20 @@ (defpack "AST-TOOLING" #:cross-clasp.clasp.ast-tooling) (defpack "EXT" #:cross-clasp.clasp.ext) (defpack "KEYWORD" #:keyword) - (defpack "ECCLESIA" #:ecclesia)) + (defpack "ECCLESIA" #:ecclesia) + (defpack "QUAVIVER" #:quaviver) + (defpack "QUAVIVER.CONDITION" #:quaviver.condition) + (defpack "QUAVIVER.MATH" #:quaviver.math) + (defpack "QUAVIVER/SCHUBFACH" #:quaviver/schubfach) + (defpack "INCLESS" #:incless) + (defpack "INRAVINA" #:inravina) + (defpack "INVISTRA" #:invistra) + (defpack "INCLESS-INTRINSIC" #:cross-clasp.clasp.incless-intrinsic) + (defpack "INRAVINA-INTRINSIC" #:cross-clasp.clasp.inravina-intrinsic) + (defpack "INVISTRA-INTRINSIC" #:cross-clasp.clasp.invistra-intrinsic) + (defpack "ECLECTOR.BASE" #:cross-clasp.clasp.eclector.base) + (defpack "ECLECTOR.READER" #:cross-clasp.clasp.eclector.reader)) + ;; on clasp we have a few symbols from its actual core, like lambda-name. ;; So we need to be able to dump those correctly. #+clasp @@ -253,7 +280,12 @@ (let ((*package* (find-package "CL"))) ;; global ext, i.e. clasp's, not ours (find-package "EXT"))) - "EXT")) + "EXT") + (loop for (host-name . target-name) in '(("INCLESS-EXTRINSIC" . "INCLESS-INTRINSIC") + ("INRAVINA-EXTRINSIC" . "INRAVINA-INTRINSIC") + ("INVISTRA-EXTRINSIC" . "INVISTRA-INTRINSIC")) + do (setf (clostrum:package-name client environment (find-package host-name)) + target-name))) ;;; FIXME: defconstant should really be in common macros. (defun core::symbol-constantp (name) @@ -296,7 +328,19 @@ ;; FEATURES are those gathered from the executable. We just tack on ;; an indication that we're building from the host Lisp, as well as :CLOS. ;; We could add :CLOS from the sources instead? - (list* :building-clasp :clos features)) + (let ((features (list* :gray-streams-line-length :gray-streams-interactive + :gray-streams-external-format/setf :gray-streams-external-format + :gray-streams-file-string-length :gray-streams-file-length/get + :gray-streams-file-length :gray-streams-file-position/optional + :gray-streams-file-position :gray-streams-sequence/optional + :gray-streams-sequence :gray-streams-truename :gray-streams-pathname + :gray-streams-directionp :gray-streams-streamp + :gray-streams-element-type/setf :building-clasp :clos features))) + (when (member :long-float features) + (pushnew :quaviver/long-float features)) + (when (member :short-float features) + (pushnew :quaviver/short-float features)) + features)) ;; This gets the currently present *features*. Used in build. (defun features () @@ -307,6 +351,8 @@ eclector.reader::*quasiquotation-state* eclector.reader::*quasiquotation-depth* eclector.reader::*consing-dot-allowed-p* + incless-extrinsic::*client* + invistra::*format-output* ;; We need these to be available for dumping cmp::*additional-clasp-character-names* cmp::*mapping-char-code-to-char-names*)) @@ -375,10 +421,15 @@ (declare (ignore ce)) (extrinsicl:install-cl client rte) (extrinsicl.maclina:install-eval client rte) + (clostrum:make-variable client rte 'CROSS-CLASP.CLASP.INCLESS-INTRINSIC:*CLIENT* incless-extrinsic:*client*) + (loop for vname in *copied-variables* + do (clostrum:make-variable client rte vname (symbol-value vname))) (loop for vname in '(core::*condition-restarts* core::*restart-clusters* core::*interrupts-enabled* core::*allow-with-interrupts* core:*quasiquote* core::*sharp-equal-final-table* core:*variable-source-infos* + cross-clasp.clasp.inravina-intrinsic::*initial-pprint-dispatch* + core::+standard-readtable+ ext:*invoke-debugger-hook* ext:*toplevel-hook* ext:*inspector-hook* core::*documentation-pool* core:*initialize-hooks* core:*terminate-hooks* @@ -391,10 +442,22 @@ ext:+process-error-output+ ext:+process-terminal-io+ cmp::*default-output-type* cmp:*source-locations* cmp::*optimize* cmp::*optimization-level* - cmp:*btb-compile-hook* cmp::*code-walker*) + cmp:*btb-compile-hook* cmp::*code-walker* + invistra::*format-output* invistra::*extra-space* + invistra::*line-length* invistra::*newline-kind* + invistra::*more-arguments-p* invistra::*argument-index* + invistra::*remaining-argument-count* invistra::*pop-argument* + invistra::*go-to-argument* invistra::*pop-remaining-arguments* + invistra::*inner-exit-if-exhausted* invistra::*outer-exit-if-exhausted* + invistra::*inner-exit* invistra::*outer-exit* + invistra::*format-output* invistra::*extra-space* + invistra::*line-length* invistra::*newline-kind* + invistra::*more-arguments-p* invistra::*argument-index* + invistra::*remaining-argument-count* invistra::*pop-argument* + invistra::*go-to-argument* invistra::*pop-remaining-arguments* + invistra::*inner-exit-if-exhausted* invistra::*outer-exit-if-exhausted* + invistra::*inner-exit* invistra::*outer-exit*) do (clostrum:make-variable client rte vname)) - (loop for vname in *copied-variables* - do (clostrum:make-variable client rte vname (symbol-value vname))) (loop for fname in '(core::symbol-constantp (setf core::symbol-constantp) (setf ext:symbol-macro) core::*make-special ext:specialp @@ -462,7 +525,21 @@ alexandria:ensure-car alexandria:ensure-list alexandria::generate-switch-body - khazern:unique-name) + quaviver::unique-name + quaviver.math::compute-expt + quaviver.math::ceiling-log-expt + quaviver::primitive-triple-bits-form + quaviver::bits-primitive-triple-form + quaviver::primitive-triple-float-form + quaviver::float-primitive-triple-form + quaviver::traits-from-sizes + khazern:unique-name + inravina:expand-logical-block + invistra::unique-name + invistra:expand-function + invistra:make-downcase-stream + incless:write-object + invistra:format-with-client) for f = (fdefinition fname) do (setf (clostrum:fdefinition client rte fname) f)) (loop for (fname . src) in '((cl:proclaim . proclaim) @@ -481,7 +558,161 @@ . %symbolicate)) for f = (fdefinition src) do (setf (clostrum:fdefinition client rte fname) f)) + (flet ((traits (type &aux (plist (case type + (:bfloat16 + '(:exponent-size 8 :significand-size 8)) + (:binary16 + '(:exponent-size 5 :significand-size 11)) + (:binary32 + '(:exponent-size 8 :significand-size 24)) + (:binary64 + '(:exponent-size 11 :significand-size 53)) + (:binary80 + '(:exponent-size 15 :significand-size 64)) + (:binary128 + '(:exponent-size 15 :significand-size 113)) + (:binary256 + '(:exponent-size 19 :significand-size 237)) + (otherwise + (clostrum:symbol-plist client rte type))))) + (quaviver::traits-from-sizes type + (getf plist :exponent-size) + (getf plist :significand-size))) + (bytespec (form) + (cons (second form) (third form)))) + (setf (clostrum:fdefinition client rte 'incless::write-object) + (fdefinition 'incless:write-object) + (clostrum:fdefinition client rte 'cl:format) + (fdefinition 'invistra-extrinsic:format) + (clostrum:compiler-macro-function client rte 'cl:format) + (compiler-macro-function 'invistra-extrinsic:format) + (clostrum:compiler-macro-function client rte 'cl:break) + (compiler-macro-function 'invistra-extrinsic:break) + (clostrum:compiler-macro-function client rte 'cl:error) + (compiler-macro-function 'invistra-extrinsic:error) + (clostrum:compiler-macro-function client rte 'cl:cerror) + (compiler-macro-function 'invistra-extrinsic:cerror) + (clostrum:compiler-macro-function client rte 'cl:invalid-method-error) + (compiler-macro-function 'invistra-extrinsic:invalid-method-error) + (clostrum:compiler-macro-function client rte 'cl:method-combination-error) + (compiler-macro-function 'invistra-extrinsic:method-combination-error) + (clostrum:compiler-macro-function client rte 'cl:signal) + (compiler-macro-function 'invistra-extrinsic:signal) + (clostrum:compiler-macro-function client rte 'cl:warn) + (compiler-macro-function 'invistra-extrinsic:warn) + (clostrum:compiler-macro-function client rte 'cl:y-or-n-p) + (compiler-macro-function 'invistra-extrinsic:y-or-n-p) + (clostrum:compiler-macro-function client rte 'cl:yes-or-no-p) + (compiler-macro-function 'invistra-extrinsic:yes-or-no-p) + (clostrum:compiler-macro-function client rte 'core::assert-failure) + (lambda (form env) + (declare (ignore env)) + (print (invistra:expand-function incless-extrinsic:*client* form 4))) + (clostrum:compiler-macro-function client rte 'cross-clasp.clasp.core::assert-failure) + (lambda (form env) + (declare (ignore env)) + (print (invistra:expand-function incless-extrinsic:*client* form 1))) + (clostrum:compiler-macro-function client rte 'core::simple-reader-error) + (lambda (form env) + (declare (ignore env)) + (invistra:expand-function incless-extrinsic:*client* form 2)) + (clostrum:compiler-macro-function client rte 'core::signal-simple-error) + (lambda (form env) + (declare (ignore env)) + (invistra:expand-function incless-extrinsic:*client* form 2 3)) + (clostrum:compiler-macro-function client rte 'mp::interrupt) + (lambda (form env) + (declare (ignore env)) + (invistra:expand-function incless-extrinsic:*client* form 3)) + (clostrum:compiler-macro-function client rte 'mp::raise) + (lambda (form env) + (declare (ignore env)) + (invistra:expand-function incless-extrinsic:*client* form 2)) + (clostrum:macro-function client rte 'cl:formatter) + (macro-function 'invistra-extrinsic:formatter) + (clostrum:macro-function client rte 'cl:print-unreadable-object) + (macro-function 'incless-extrinsic:print-unreadable-object) + (clostrum:fdefinition client rte 'cross-clasp.clasp.gray::redefine-cl-functions) + (lambda ()) + (clostrum:fdefinition client rte 'quaviver::bits-float-form) + (lambda (type value) + (ecase (getf (clostrum:symbol-plist client rte type) :implementation-type) + (short-float + `(ext::bits-to-short-float ,value)) + (single-float + `(ext::bits-to-single-float ,value)) + (double-float + `(ext::bits-to-double-float ,value)) + (long-float + `(ext::bits-to-long-float ,value)))) + (clostrum:fdefinition client rte 'quaviver::float-bits-form) + (lambda (type value) + (ecase (getf (clostrum:symbol-plist client rte type) :implementation-type) + (short-float + `(ext::short-float-to-bits ,value)) + (single-float + `(ext::single-float-to-bits ,value)) + (double-float + `(ext::double-float-to-bits ,value)) + (long-float + `(ext::long-float-to-bits ,value)))) + (clostrum:fdefinition client rte 'quaviver::implementation-type) + (lambda (type) + (or (getf (clostrum:symbol-plist client rte type) :implementation-type) + (getf (traits type) :implementation-type))) + (clostrum:fdefinition client rte + 'quaviver::exact-implementation-type-p) + (lambda (type) + (getf (traits type) :exact-implementation-type-p)) + (clostrum:fdefinition client rte 'quaviver::exponent-size) + (lambda (type) + (getf (traits type) :exponent-size)) + (clostrum:fdefinition client rte 'quaviver::significand-size) + (lambda (type) + (getf (traits type) :significand-size)) + (clostrum:fdefinition client rte 'quaviver::arithmetic-size) + (lambda (type) + (getf (traits type) :arithmetic-size)) + (clostrum:fdefinition client rte 'quaviver::max-exponent) + (lambda (type) + (getf (traits type) :max-exponent)) + (clostrum:fdefinition client rte 'quaviver::min-exponent) + (lambda (type) + (getf (traits type) :min-exponent)) + (clostrum:fdefinition client rte 'quaviver::exponent-bias) + (lambda (type) + (getf (traits type) :exponent-bias)) + (clostrum:fdefinition client rte 'quaviver::storage-size) + (lambda (type) + (getf (traits type) :storage-size)) + (clostrum:fdefinition client rte 'quaviver::sign-byte-form) + (lambda (type) + (getf (traits type) :sign-byte-form)) + (clostrum:fdefinition client rte 'quaviver::exponent-byte-form) + (lambda (type) + (getf (traits type) :exponent-byte-form)) + (clostrum:fdefinition client rte 'quaviver::exponent-bytespec) + (lambda (type) + (bytespec (getf (traits type) :exponent-byte-form))) + (clostrum:fdefinition client rte 'quaviver::significand-byte-form) + (lambda (type) + (getf (traits type) :significand-byte-form)) + (clostrum:fdefinition client rte 'quaviver::significand-bytespec) + (lambda (type) + (bytespec (getf (traits type) :significand-byte-form))) + (clostrum:fdefinition client rte 'quaviver::nan-type-byte-form) + (lambda (type) + (getf (traits type) :nan-type-byte-form)) + (clostrum:fdefinition client rte 'quaviver::nan-payload-byte-form) + (lambda (type) + (getf (traits type) :nan-payload-byte-form)) + (clostrum:fdefinition client rte 'quaviver::hidden-bit-p) + (lambda (type) + (getf (traits type) :hidden-bit-p)))) + (loop for mname in '(eclector.reader:quasiquote + invistra::with-arguments + invistra::with-remaining-arguments #+clasp si:quasiquote ext:with-current-source-form core::with-clean-symbols core::with-unique-names @@ -538,6 +769,7 @@ (etypecase . core::%etypecase) (setf . %setf) (remf . %remf) + (pprint-logical-block . core::%pprint-logical-block) (trivial-with-current-source-form:with-current-source-form . ext:with-current-source-form)) for m = (macro-function src) diff --git a/src/cross-clasp/clos/generics.lisp b/src/cross-clasp/clos/generics.lisp index 77c00b69de..0a587fa14e 100644 --- a/src/cross-clasp/clos/generics.lisp +++ b/src/cross-clasp/clos/generics.lisp @@ -175,7 +175,7 @@ (symbol (cross-clasp:find-compiler-class spec)) ((cons (eql eql) (cons (cons (eql quote) (cons t null)) null)) (intern-eql-specializer (second (second spec)))) - ((cons (eql eql) (cons (not (or cons symbol)) null)) ; (eql [self-evaluating]) + ((cons (eql eql) (cons (or keyword null (eql t) (not (or cons symbol))) null)) ; (eql [self-evaluating]) (intern-eql-specializer (second spec))) ((cons (eql eql) (cons t null)) (error "Can't handle evaluated EQL specializer: ~a" spec)))) diff --git a/src/cross-clasp/condition-system-macros.lisp b/src/cross-clasp/condition-system-macros.lisp index 1f1ba60319..e457a6a67f 100644 --- a/src/cross-clasp/condition-system-macros.lisp +++ b/src/cross-clasp/condition-system-macros.lisp @@ -161,14 +161,14 @@ ,temp-var)))))))) -(defmacro %assert (test-form &optional places (datum nil datump) &rest arguments) +(defmacro %assert (test-form &optional places datum &rest arguments) `(core::while (not ,test-form) (setf (values ,@places) ;; Defined in clos/conditions.lisp (core::assert-failure ',test-form ',places (list ,@places) - ;; If DATUM is provided, it must be for a - ;; condition; NIL is not acceptable. - ,(if datump datum nil) ,@arguments)))) + ,(invistra:maybe-expand-formatter incless-extrinsic:*client* + datum) + ,@arguments)))) (defmacro %check-type (place type &optional type-string) (when (and (consp type) (eq 'quote (car type))) diff --git a/src/cross-clasp/cross-clasp.asd b/src/cross-clasp/cross-clasp.asd index 06f0c70e06..d4bf877025 100644 --- a/src/cross-clasp/cross-clasp.asd +++ b/src/cross-clasp/cross-clasp.asd @@ -1,7 +1,7 @@ -(asdf:defsystem #:cross-clasp - :depends-on (:maclina :closer-mop :extrinsicl :extrinsicl/maclina :anatomicl - :alexandria :ecclesia :clostrum-basic - :trivial-package-local-nicknames :eclector) +(asdf:defsystem "cross-clasp" + :depends-on ("maclina" "closer-mop" "extrinsicl" "extrinsicl/maclina" "anatomicl" + "alexandria" "ecclesia" "clostrum-basic" "invistra-extrinsic" + "trivial-package-local-nicknames" "eclector") :components ((:file "packages") (:file "vm-clasp" :depends-on ("packages") :if-feature :clasp) (:file "trucler-clasp" :depends-on ("packages") @@ -29,6 +29,7 @@ (:file "define-unicode-tables" :depends-on ("packages")) (:file "opt" :depends-on ("packages")) (:file "source-pos-info" :depends-on ("packages")) + ;(:file "printer" :depends-on ("packages")) (:file "base" :depends-on ("environment" "clos" "defstruct" "condition-system-macros" "mp-macros" "mp-atomics" diff --git a/src/cross-clasp/macrology.lisp b/src/cross-clasp/macrology.lisp index 8e260133b3..84e4b2a3e4 100644 --- a/src/cross-clasp/macrology.lisp +++ b/src/cross-clasp/macrology.lisp @@ -1,5 +1,14 @@ (in-package #:cross-clasp.clasp.core) +(defmacro %pprint-logical-block + ((stream-symbol object + &key (prefix "" prefix-p) (per-line-prefix "" per-line-prefix-p) (suffix "" suffix-p)) + &body body) + (inravina:expand-logical-block 'cross-clasp.clasp.incless-intrinsic:*client* stream-symbol + object prefix prefix-p per-line-prefix per-line-prefix-p + suffix suffix-p 'pprint-exit-if-list-exhausted 'pprint-pop nil + body)) + (defmacro with-unique-names (symbols &body body) `(let* ,(mapcar (lambda (symbol) (let* ((symbol-name (symbol-name symbol)) diff --git a/src/cross-clasp/packages.lisp b/src/cross-clasp/packages.lisp index f9e8a0d2b1..29098bcdfe 100644 --- a/src/cross-clasp/packages.lisp +++ b/src/cross-clasp/packages.lisp @@ -364,6 +364,17 @@ #:stream-line-length #:stream-line-column #:stream-file-position #:stream-advance-to-column)) +(defpackage #:cross-clasp.clasp.incless-intrinsic + (:use #:cl) + (:export #:*client* + #:client)) +(defpackage #:cross-clasp.clasp.inravina-intrinsic + (:use #:cl) + (:export #:client)) +(defpackage #:cross-clasp.clasp.invistra-intrinsic + (:use #:cl) + (:export #:client)) + (defpackage #:cross-clasp (:use #:cl) (:local-nicknames (#:m #:maclina.machine) diff --git a/src/koga/ninja.lisp b/src/koga/ninja.lisp index dfdb152f17..42010d34f1 100644 --- a/src/koga/ninja.lisp +++ b/src/koga/ninja.lisp @@ -660,6 +660,10 @@ :sources (make-kernel-source-list configuration sources) :outputs fasls + :implicit-inputs (list runtime-packages.lisp + cxx-classes.lisp runtime-functions.lisp + runtime-variables.lisp runtime-info.lisp + type-map.lisp fli-specs.lisp) :implicit-outputs cfasls) (ninja:write-build output-stream :link-image :inputs fasls diff --git a/src/koga/scripts.lisp b/src/koga/scripts.lisp index a99d155155..a35f48e374 100644 --- a/src/koga/scripts.lisp +++ b/src/koga/scripts.lisp @@ -30,7 +30,8 @@ (defmethod print-prologue (configuration (name (eql :generate-lisp-info)) output-stream) (declare (ignore configuration)) (format output-stream "~ -(print *features* (open (core:argv 3) :if-exists :overwrite :if-does-not-exist :create :direction :output)) +(print (list* :quaviver/boot *features*) + (open (core:argv 3) :if-exists :overwrite :if-does-not-exist :create :direction :output)) (let ((o (open (core:argv 4) :if-exists :overwrite :if-does-not-exist :create :direction :output))) (write-line \"(eval-when (:compile-toplevel)\" o) (mapc #'(lambda (p) @@ -91,7 +92,12 @@ (maphash #'frob int)) (core:package-hash-tables p)))) (list-all-packages))) - ss)) + ss) + (setf ,@(mapcan #'(lambda (q) + (mapcan #'(lambda (pair) + `((get ',(car q) ,(car pair)) ',(cdr pair))) + (cdr q))) + (core:float-traits)))) (open (core:argv 7) :if-exists :overwrite :if-does-not-exist :create :direction :output)) (let ((s (open (core:argv 8) :if-exists :overwrite :if-does-not-exist :create :direction :output))) (print `(in-package #:cmp) s) diff --git a/src/lisp/cscript.lisp b/src/lisp/cscript.lisp index 3a935738d0..1485903995 100644 --- a/src/lisp/cscript.lisp +++ b/src/lisp/cscript.lisp @@ -39,13 +39,12 @@ #~"kernel/lsp/predlib.lisp" #~"kernel/lsp/cdr-5.lisp" #~"kernel/lsp/module.lisp" - #~"kernel/clos/streams.lisp" - #~"kernel/lsp/pprint.lisp" #~"kernel/lsp/listlib.lisp" #~"kernel/lsp/mislib.lisp" #~"kernel/lsp/seqmacros.lisp" #~"kernel/lsp/seq.lisp" #~"kernel/lsp/seqlib.lisp" + #~"kernel/clos/streams.lisp" #~"kernel/lsp/iolib.lisp" #~"kernel/lsp/trace.lisp" #~"kernel/lsp/assorted.lisp" @@ -62,6 +61,7 @@ #~"kernel/clos/cpl.lisp" #~"kernel/clos/generic.lisp" #~"kernel/clos/method.lisp" + #~"kernel/lsp/early-printer.lisp" ;; compiler #~"kernel/cmp/cmputil.lisp" #~"kernel/cmp/compiler-conditions.lisp" @@ -84,15 +84,12 @@ #~"kernel/cmp/opt/opt-cons.lisp" #~"kernel/cmp/opt/opt-array.lisp" #~"kernel/cmp/opt/opt-object.lisp" - #~"kernel/cmp/opt/opt-print.lisp" ;; macros #~"kernel/lsp/cmuutil.lisp" #~"kernel/lsp/shiftf-rotatef.lisp" #~"kernel/lsp/setf.lisp" #~"kernel/lsp/do.lisp" #~"kernel/lsp/defpackage.lisp" - #~"kernel/lsp/format.lisp" - #~"kernel/lsp/format-pprint.lisp" #~"kernel/lsp/defmacro.lisp" #~"kernel/lsp/evalmacros.lisp" #~"kernel/lsp/defstruct.lisp" @@ -117,6 +114,8 @@ #~"kernel/install-delayed-macros.lisp" :ecclesia :khazern-extension-intrinsic + :invistra-intrinsic + #~"kernel/lsp/late-printer.lisp" ;; logical pathname translation #@"base-translations.lisp" #~"modules/sockets/sockets.lisp" @@ -202,11 +201,21 @@ (k:sources :install-code #~"modules/" #~"kernel/contrib/Acclimation/" - #~"kernel/contrib/alexandria/" #~"kernel/contrib/Cleavir/" - #~"kernel/contrib/closer-mop/" #~"kernel/contrib/Concrete-Syntax-Tree/" - #~"kernel/contrib/Eclector/") + #~"kernel/contrib/Ecclesia/" + #~"kernel/contrib/Eclector/" + #~"kernel/contrib/Incless/" + #~"kernel/contrib/Inravina/" + #~"kernel/contrib/Invistra/" + #~"kernel/contrib/Khazern/" + #~"kernel/contrib/Quaviver/" + #~"kernel/contrib/alexandria/" + #~"kernel/contrib/closer-mop/" + #~"kernel/contrib/nontrivial-gray-streams/" + #~"kernel/contrib/trivial-features/" + #~"kernel/contrib/trivial-package-locks/" + #~"kernel/contrib/trivial-with-current-source-form/") (k:sources :install-extension-code #~"kernel/contrib/anaphora/" @@ -229,7 +238,6 @@ #~"kernel/contrib/plump/" #~"kernel/contrib/split-sequence/" #~"kernel/contrib/static-vectors/" - #~"kernel/contrib/trivial-features/" #~"kernel/contrib/trivial-garbage/" #~"kernel/contrib/trivial-http/" #~"kernel/contrib/trivial-indent/" diff --git a/src/lisp/kernel/cleavir/cmpintrinsics.lisp b/src/lisp/kernel/cleavir/cmpintrinsics.lisp index 052c284e59..bde7a7875e 100644 --- a/src/lisp/kernel/cleavir/cmpintrinsics.lisp +++ b/src/lisp/kernel/cleavir/cmpintrinsics.lisp @@ -95,7 +95,7 @@ names to offsets." ) (let ((final `(progn ,define-symbol-macro - (defparameter ,(intern (format nil "INFO.~a" name)) + (defparameter ,(intern (concatenate 'string "INFO." (symbol-name name))) (make-c++-struct :name ,name :tag ,tag :type-getter (lambda () (progn ,name)) diff --git a/src/lisp/kernel/cleavir/disassemble.lisp b/src/lisp/kernel/cleavir/disassemble.lisp index 46851eb4d6..b74c2c64f0 100644 --- a/src/lisp/kernel/cleavir/disassemble.lisp +++ b/src/lisp/kernel/cleavir/disassemble.lisp @@ -16,9 +16,8 @@ (core:lookup-address address) (if symbol (progn - (format t "Entry point ~a~%" (if (fixnump entry-point-name) - (format nil "xep~a" entry-point-name) - (string entry-point-name))) + (format t "Entry point ~:[~;xep~]~a~%" + (fixnump entry-point-name) entry-point-name) (disassemble-assembly start end)) (format t "; could not locate code object (bug?)~%")))))))) diff --git a/src/lisp/kernel/clos/conditions.lisp b/src/lisp/kernel/clos/conditions.lisp index 72cd53c2e1..514642a538 100644 --- a/src/lisp/kernel/clos/conditions.lisp +++ b/src/lisp/kernel/clos/conditions.lisp @@ -1508,7 +1508,7 @@ Interrupts are implicitly blocked while signaling an interrupt, and while unwind ;;; ECL's interface to the toplevel and debugger ;;; This is a redefinition, clobbering core__universal_error_handler in lisp.cc. -(defun sys::universal-error-handler (continue-string datum args) +(defun sys::universal-error-handler (continue-control datum args) "Args: (error-name continuable-p function-name continue-format-string error-format-string &rest args) @@ -1524,25 +1524,26 @@ bstrings." (clasp-debug:with-truncated-stack () (let ((condition (coerce-to-condition datum args 'simple-error 'error))) (cond - ((eq t continue-string) + ((eq t continue-control) ; from CEerror; mostly allocation errors (with-simple-restart (ignore "Ignore the error, and try the operation again") (%signal condition) (invoke-debugger condition))) - ((stringp continue-string) - (with-simple-restart (continue "~?" continue-string args) + ((or (stringp continue-control) + (functionp continue-control)) + (with-simple-restart (continue continue-control args) (%signal condition) (invoke-debugger condition))) - ((and continue-string (symbolp continue-string)) + ((and continue-control (symbolp continue-control)) ; from CEerror (with-simple-restart (accept "Accept the error, returning NIL") (multiple-value-bind (rv used-restart) (with-simple-restart (ignore "Ignore the error, and try the operation again") (multiple-value-bind (rv used-restart) - (with-simple-restart (continue "Continue, using ~S" continue-string) + (with-simple-restart (continue "Continue, using ~S" continue-control) (%signal condition) (invoke-debugger condition)) - (if used-restart continue-string rv))) + (if used-restart continue-control rv))) (if used-restart t rv)))) (t (%signal condition) diff --git a/src/lisp/kernel/clos/make-load-form.lisp b/src/lisp/kernel/clos/make-load-form.lisp index ef00f701a4..695236385a 100644 --- a/src/lisp/kernel/clos/make-load-form.lisp +++ b/src/lisp/kernel/clos/make-load-form.lisp @@ -210,3 +210,7 @@ printer and we should rather use MAKE-LOAD-FORM." ',object ',(core:source-pos-info-inlined-at object) ',(core:source-pos-info-function-scope object)))) + +(defmethod make-load-form ((object invistra-intrinsic::client-impl) &optional environment) + (make-load-form-saving-slots object :environment environment)) + diff --git a/src/lisp/kernel/clos/print.lisp b/src/lisp/kernel/clos/print.lisp index 3c50e18b8e..6a2315e66c 100644 --- a/src/lisp/kernel/clos/print.lisp +++ b/src/lisp/kernel/clos/print.lisp @@ -5,7 +5,7 @@ (defmethod print-object (object stream) (core::write-ugly-object object stream)) -(defmacro print-unreadable-object ((object stream &key type identity) &body body) +#+(or)(defmacro print-unreadable-object ((object stream &key type identity) &body body) ;; this function is defined later in iolib.lisp. `(core::%print-unreadable-object ,object ,stream ,type ,identity ,(when body diff --git a/src/lisp/kernel/clos/streams.lisp b/src/lisp/kernel/clos/streams.lisp index eb9111d42e..a9eab34c2f 100644 --- a/src/lisp/kernel/clos/streams.lisp +++ b/src/lisp/kernel/clos/streams.lisp @@ -10,6 +10,9 @@ ;;;; See file '../Copyright' for full details. ;;;; The CLOS IO library. +#+building-clasp +(ext:add-implementation-package '("GRAY") "CL") + (in-package "GRAY") (unexport '(%close @@ -35,11 +38,7 @@ ;;; ;;; This is the generic function interface for CLOS streams. ;;; -;;; The following is a port of SBCL's implementation of Gray Streams. Minor -;;; caveats with respect to the proposal are that we rather keep CLOSE, -;;; STREAM-ELEMENT-TYPE, INPUT-STREAM-P, OUTPUT-STREAM-P and OPEN-STREAM-P -;;; these as normal functions that call the user extensible EXT:STREAM-{CLOSE, -;;; ELT-TYPE, INPUT-P, OUTPUT-P, OPEN-P}. +;;; The following is a port of SBCL's implementation of Gray Streams. ;;; (defgeneric stream-advance-to-column (stream column) @@ -145,7 +144,6 @@ truename.")) (:documentation "Return the stream line length or NIL.")) (defgeneric stream-listen (stream) - #+sb-doc (:documentation "This is used by LISTEN. It returns true or false. The default method uses STREAM-READ-CHAR-NO-HANG and STREAM-UNREAD-CHAR. Most streams should @@ -282,7 +280,6 @@ truename.")) will be read, or NIL if that is not meaningful for this stream. The first line is numbered 1. The default method returns NIL.")) - ;;; ;;; Our class hierarchy looks like the one from Gray streams ;;; @@ -334,7 +331,6 @@ truename.")) (fundamental-output-stream fundamental-binary-stream) ()) - ;;; ;;; The following methods constitute default implementations. ;;; @@ -349,8 +345,7 @@ truename.")) (defmethod stream-advance-to-column ((stream ansi-stream) column) (%stream-advance-to-column stream column)) -(defmethod stream-advance-to-column ((stream fundamental-character-output-stream) - column) +(defmethod stream-advance-to-column ((stream fundamental-character-output-stream) column) (let ((current-column (stream-line-column stream))) (when current-column (let ((fill (floor (- column current-column)))) @@ -358,7 +353,6 @@ truename.")) (stream-write-char stream #\Space))) t))) - ;; CLEAR-INPUT (defmethod stream-clear-input ((stream fundamental-input-stream)) @@ -890,52 +884,32 @@ truename.")) ;;; Setup -(core:defconstant-equal +conflicting-symbols+ - '(cl:close - cl:stream-element-type - cl:stream-external-format - cl:input-stream-p - cl:open-stream-p - cl:output-stream-p - cl:streamp - cl:pathname - cl:truename)) - -(defun redefine-cl-functions () - "Some functions in CL package are expected to be generic. We make them so." - (provide '#:gray-streams) - (let ((lockedcl (ext:package-locked-p "COMMON-LISP"))) - (ext:unlock-package "COMMON-LISP") - (loop with gray-package = (find-package "GRAY") - finally (when lockedcl (ext:lock-package "COMMON-LISP")) - for cl-symbol in '#.+conflicting-symbols+ - for gray-symbol = (find-symbol (symbol-name cl-symbol) gray-package) - unless (typep (fdefinition cl-symbol) 'generic-function) - do (setf (fdefinition cl-symbol) - (fdefinition gray-symbol)) - (when (fboundp `(setf ,gray-symbol)) - (setf (fdefinition `(setf ,cl-symbol)) - (fdefinition `(setf ,gray-symbol)))) - (unintern gray-symbol gray-package) - (import cl-symbol gray-package) - (export cl-symbol gray-package)) - nil)) +(defun redefine-cl-functions ()) -(pushnew :gray-streams-module *features*) +(provide '#:gray-streams) -(defun gray-streams-module-provider (name) - (when (string= name '#:gray-streams) - (redefine-cl-functions) - t)) +(pushnew :gray-streams-module *features*) -(pushnew 'gray-streams-module-provider ext:*module-provider-functions*) +(unless (typep (fdefinition 'cl:streamp) 'generic-function) + (setf (fdefinition 'cl:streamp) (fdefinition 'gray:streamp)) + (unintern 'gray:streamp "GRAY") + (import 'cl:streamp "GRAY") + (export 'cl:streamp "GRAY")) -(export '(fundamental-stream - fundamental-input-stream - fundamental-output-stream - fundamental-character-stream +(export '(close + fundamental-binary-input-stream + fundamental-binary-output-stream fundamental-binary-stream fundamental-character-input-stream fundamental-character-output-stream - fundamental-binary-input-stream - fundamental-binary-output-stream)) + fundamental-character-stream + fundamental-input-stream + fundamental-output-stream + fundamental-stream + input-stream-p + open-stream-p + output-stream-p + pathname + stream-element-type + stream-external-format + truename)) diff --git a/src/lisp/kernel/cmp/bytecode-machines.lisp b/src/lisp/kernel/cmp/bytecode-machines.lisp index a56ee68477..95a5adf833 100644 --- a/src/lisp/kernel/cmp/bytecode-machines.lisp +++ b/src/lisp/kernel/cmp/bytecode-machines.lisp @@ -37,7 +37,7 @@ (long-arguments (mapcar (lambda (code) (eval code)) long-argument-codes))) (push (list name code arguments long-arguments) rev-fullcodes)) (push name rev-codes) - (let ((sym (intern (format nil "+~a+" (string-upcase name)))) + (let ((sym (intern (concatenate 'string "+" (string-upcase name) "+"))) (cd code)) (push `(defconstant ,sym ,cd) rev-defconstants)))) `(progn @@ -132,9 +132,8 @@ (when (integerp arg) (push (format nil "~d" arg) rev-args)) (when (consp arg) - (push (let* ((fn-name (string-downcase (format nil "~a" (car arg)))) - (fn-underscore-name (substitute #\_ #\- fn-name)) - (num-arg (second arg))) + (push (let ((fn-underscore-name (substitute #\_ #\- (format nil "~(~a~)" (car arg)))) + (num-arg (second arg))) (format nil "~a(~d)" fn-underscore-name num-arg)) rev-args))) (nreverse rev-args))) diff --git a/src/lisp/kernel/cmp/opt/opt-print.lisp b/src/lisp/kernel/cmp/opt/opt-print.lisp deleted file mode 100644 index 3eeeb56f02..0000000000 --- a/src/lisp/kernel/cmp/opt/opt-print.lisp +++ /dev/null @@ -1,97 +0,0 @@ -(in-package #:core) - -;;; I don't see any problem with the following code to "inline" write and -;;; write-to-string, but it's broken. During build it causes weird integers -;;; to be printed apparently randomly, and there's an error while building -;;; ASDF. -#+(or) -(progn - -(defvar *printer-variables* - ;; :stream excepted as it's not dynamic. - '((:escape *print-escape*) (:radix *print-radix*) (:base *print-base*) - (:circle *print-circle*) (:pretty *print-pretty*) (:level *print-level*) - (:length *print-length*) (:case *print-case*) (:array *print-array*) - (:gensym *print-gensym*) (:readably *print-readably*) - (:right-margin *print-right-margin*) (:miser-width *print-miser-width*) - (:lines *print-lines*) (:pprint-dispatch *print-pprint-dispatch*))) - -;; Given a keyword argument list, return three values: -;; A list of bindings of variables to argument forms -;; some are printer variables, but any duplicates will get a gensym -;; A variable that can be evaluated to get the stream to write to -;; T iff the arguments were valid. -;; (invalidity would be due to e.g. non-constant keywords.) -(defun parse-printer-keys (kwargs env streamp) - (let ((bindings nil) - (stream '*standard-output*) - (seen-stream-p nil) - (info (loop for (key var) in *printer-variables* - collect (list key var nil)))) - (loop for (keywordf arg) on kwargs by #'cddr - for keyword = (if (constantp keywordf env) - (ext:constant-form-value keywordf env) - ;; variable keyword - (return (values nil nil nil))) - do (case keyword - ((:allow-other-keys) - ;; If we have seen :allow-other-keys, we just give up on - ;; expanding - that's a weird case to deal with. - (return (values nil nil nil))) - ((:stream) - (if streamp - (let ((temp (gensym "STREAM"))) - (when seen-stream-p - (setf seen-stream-p t stream temp)) - (push `(,temp ,arg) bindings)) - ;; invalid keyword - (return (values nil nil nil)))) - (t (let ((i (assoc keyword info))) - (cond ((null i) ; invalid keyword - (return (values nil nil nil))) - ((third i) ; seen already - (push `(,(gensym) ,arg) bindings)) - (t - (setf (third i) t) ; mark seen - (push `(,(second i) ,arg) bindings)))))) - finally - (return - (values (nreverse bindings) stream t))))) - -(define-compiler-macro write (&whole form object &rest keys - &key &allow-other-keys - &environment env) - (multiple-value-bind (bindings stream validp) - (parse-printer-keys keys env t) - (if validp - (let ((osym (gensym "OBJECT"))) - `(let ((,osym ,object) ,@bindings) - (declare (ignorable ,@(mapcar #'first bindings))) - (write-object ,osym ,stream))) - form))) - -(define-compiler-macro write-to-string - (&whole form object &rest keys &key &allow-other-keys &environment env) - (multiple-value-bind (bindings stream validp) - (parse-printer-keys keys env nil) - (declare (ignore stream)) - (if validp - (let ((osym (gensym "OBJECT"))) - `(let ((,osym ,object) ,@bindings) - (declare (ignorable ,@(mapcar #'first bindings))) - (stringify ,osym))) - form))) - -) ; #+(or) - -;;; These are more or less inlines. KLUDGE. -(define-compiler-macro prin1 (object &optional (stream '*standard-output*)) - `(let ((*print-escape* t)) (write-object ,object ,stream))) -(define-compiler-macro princ (object &optional (stream '*standard-output*)) - `(let ((*print-escape* nil) (*print-readably* nil)) - (write-object ,object ,stream))) - -(define-compiler-macro prin1-to-string (object) - `(let ((*print-escape* t)) (stringify ,object))) -(define-compiler-macro princ-to-string (object) - `(let ((*print-escape* nil) (*print-readably* nil)) (stringify ,object))) diff --git a/src/lisp/kernel/contrib-packages.lisp b/src/lisp/kernel/contrib-packages.lisp index 434af230f5..213ae6df89 100644 --- a/src/lisp/kernel/contrib-packages.lisp +++ b/src/lisp/kernel/contrib-packages.lisp @@ -1,3 +1,79 @@ (in-package #:core) (make-package "ECCLESIA" :use '("CL")) +(make-package "QUAVIVER/SCHUBFACH" :use '("CL")) +(make-package "INCLESS" :use '("CL")) + +(make-package "INCLESS-INTRINSIC" :use '("CL")) +(make-package "INRAVINA" :use '("CL")) +(shadow '(#:copy-pprint-dispatch + #:pprint-dispatch + #:pprint-exit-if-list-exhausted + #:pprint-fill + #:pprint-indent + #:pprint-linear + #:pprint-logical-block + #:pprint-newline + #:pprint-pop + #:pprint-tab + #:pprint-tabular + #:set-pprint-dispatch) + "INRAVINA") +(make-package "INRAVINA-INTRINSIC" :use '("CL")) +(make-package "INVISTRA" :use '("CL")) +(make-package "INVISTRA-INTRINSIC" :use '("CL")) + +(in-package #:invistra) + +(defvar *format-output* nil) + +(defparameter *extra-space* nil) + +(defparameter *line-length* nil) + +(defparameter *newline-kind* nil) + +(defvar *more-arguments-p* nil) + +(defvar *argument-index* nil) + +(defvar *remaining-argument-count* nil) + +(defvar *pop-argument* nil) + +(defvar *go-to-argument* nil) + +(defvar *pop-remaining-arguments* nil) + +(defvar *inner-exit-if-exhausted* nil) + +(defvar *outer-exit-if-exhausted* nil) + +(defvar *inner-exit* nil) + +(defvar *outer-exit* nil) + +(defun format-with-client (client destination control &rest args) + (declare (ignore client)) + (let ((*format-output* (cond ((null destination) + (make-string-output-stream)) + ((eq destination t) + *standard-output*) + (t + destination)))) + (apply control *format-output* args) + (if (null destination) + (get-output-stream-string *format-output*) + nil))) + +(in-package #:incless) + +(declaim (ftype (function (t t t t t t) t) write-unreadable-object)) + +(in-package #:incless-intrinsic) + +(defvar *client* nil) + +(in-package #:inravina-intrinsic) + +(defvar *standard-pprint-dispatch* nil) diff --git a/src/lisp/kernel/lsp/assert.lisp b/src/lisp/kernel/lsp/assert.lisp index 1dded39d09..4494759c94 100644 --- a/src/lisp/kernel/lsp/assert.lisp +++ b/src/lisp/kernel/lsp/assert.lisp @@ -83,7 +83,8 @@ until FORM returns a non-NIL value. Returns NIL. DATUM and ARGs designate the (assert-failure ',test-form ',places (list ,@places) ;; If DATUM is provided, it must be for a ;; condition; NIL is not acceptable. - ,(if datump datum nil) ,@arguments)))) + ,(invistra:maybe-expand-formatter incless-intrinsic:*client* datum) + ,@arguments)))) (eval-when (:compile-toplevel :load-toplevel :execute) (defun accumulate-cases (cases list-is-atom-p) diff --git a/src/lisp/kernel/lsp/describe.lisp b/src/lisp/kernel/lsp/describe.lisp index 680cf47ab2..a94135959e 100644 --- a/src/lisp/kernel/lsp/describe.lisp +++ b/src/lisp/kernel/lsp/describe.lisp @@ -55,17 +55,17 @@ (defun select-? () (terpri) (format t - "Inspect commands:~%~ - n (or N or Newline): inspects the field (recursively).~%~ - s (or S): skips the field.~%~ - p (or P): pretty-prints the field.~%~ - a (or A): aborts the inspection ~ - of the rest of the fields.~%~ - u (or U) form: updates the field ~ - with the value of the form.~%~ - e (or E) form: evaluates and prints the form.~%~ - q (or Q): quits the inspection.~%~ - ?: prints this.~%~%")) + "Inspect commands:~@ + n (or N or Newline): inspects the field (recursively).~@ + s (or S): skips the field.~@ + p (or P): pretty-prints the field.~@ + a (or A): aborts the inspection ~ + of the rest of the fields.~@ + u (or U) form: updates the field ~ + with the value of the form.~@ + e (or E) form: evaluates and prints the form.~@ + q (or Q): quits the inspection.~@ + ?: prints this.~2%")) (defun read-inspect-command (label object allow-recursive) (declare (special *quit-tag* *quit-tags*)) @@ -149,6 +149,8 @@ (terpri)))) (defmacro inspect-print (label object &optional place) + (when (stringp label) + (setf label `(formatter ,label))) (if place `(multiple-value-bind (update-flag new-value) (read-inspect-command ,label ,object nil) @@ -256,17 +258,17 @@ (defun inspect-cons (cons) (format t "~S - cons" cons) (when *inspect-mode* - (do ((i 0 (1+ i)) - (l cons (cdr l))) - ((atom l) - (case l - ((t nil) ;; no point in inspecting recursively t nor nil. - (inspect-print (format nil "nthcdr ~D: ~~S" i) l)) - (t - (inspect-recursively (format nil "nthcdr ~D:" i) - l (cdr (nthcdr (1- i) cons)))))) - (inspect-recursively (format nil "nth ~D:" i) - (car l) (nth i cons))))) + (do ((i 0 (1+ i)) + (l cons (cdr l))) + ((atom l) + (case l + ((t nil) ;; no point in inspecting recursively t nor nil. + (inspect-print (format nil "nthcdr ~D: ~~S" i) l)) + (t + (inspect-recursively (format nil "nthcdr ~D:" i) + l (cdr (nthcdr (1- i) cons)))))) + (inspect-recursively (format nil "nth ~D:" i) + (car l) (nth i cons))))) (defun inspect-string (string) (format t (if (simple-string-p string) "~S - simple string" "~S - string") @@ -466,28 +468,27 @@ q (or Q): quits the inspection.~%~ (when (and (not *inspect-mode*) (or (> *inspect-level* 5) (member object *inspect-history*))) - (prin1 object) - (return-from inspect-object)) + (prin1 object) + (return-from inspect-object)) (incf *inspect-level*) (push object *inspect-history*) (catch 'ABORT-INSPECT (let ((* object)) - (cond - ((symbolp object) (inspect-symbol object)) - ((packagep object) (inspect-package object)) - ((characterp object) (inspect-character object)) - ((numberp object) (inspect-number object)) - ((consp object) (inspect-cons object)) - ((stringp object) (inspect-string object)) - ((vectorp object) (inspect-vector object)) - ((arrayp object) (inspect-array object)) - ((hash-table-p object) (inspect-hashtable object)) - ;; Note that this needs to get generic functions, - ;; so keep it before the instancep test. - ((functionp object) (inspect-function object)) - ((sys:instancep object) (inspect-instance object)) - ((sys:cxx-object-p object) (describe-object object *standard-output*)) - (t (format t "~S - ~S" object (type-of object))))))) + (cond ((symbolp object) (inspect-symbol object)) + ((packagep object) (inspect-package object)) + ((characterp object) (inspect-character object)) + ((numberp object) (inspect-number object)) + ((consp object) (inspect-cons object)) + ((stringp object) (inspect-string object)) + ((vectorp object) (inspect-vector object)) + ((arrayp object) (inspect-array object)) + ((hash-table-p object) (inspect-hashtable object)) + ;; Note that this needs to get generic functions, + ;; so keep it before the instancep test. + ((functionp object) (inspect-function object)) + ((sys:instancep object) (inspect-instance object)) + ((sys:cxx-object-p object) (describe-object object *standard-output*)) + (t (format t "~S - ~S" object (type-of object))))))) (defun default-inspector (object) "Args: (object) @@ -516,17 +517,17 @@ inspect commands, or type '?' to the inspector." object) (defun describe (object &optional (stream *standard-output*) - &aux (*inspect-mode* nil) - (*inspect-level* 0) - (*inspect-history* nil) - (*print-level* nil) - (*print-length* nil) - (*standard-output* (cond ((streamp stream) stream) - ((null stream) *standard-output*) - ((eq stream t) *terminal-io*) - (t (error 'type-error - :datum stream - :expected-type '(or stream t nil)))))) + &aux (*inspect-mode* nil) + (*inspect-level* 0) + (*inspect-history* nil) + (*print-level* nil) + (*print-length* nil) + (*standard-output* (cond ((streamp stream) stream) + ((null stream) *standard-output*) + ((eq stream t) *terminal-io*) + (t (error 'type-error + :datum stream + :expected-type '(or stream t nil)))))) "Args: (object &optional (stream *standard-output*)) Prints information about OBJECT to STREAM." (terpri) diff --git a/src/lisp/kernel/lsp/early-printer.lisp b/src/lisp/kernel/lsp/early-printer.lisp new file mode 100644 index 0000000000..1b1a30160e --- /dev/null +++ b/src/lisp/kernel/lsp/early-printer.lisp @@ -0,0 +1,14 @@ +(in-package #:incless) + +(defgeneric write-object (client object stream) + (:method ((client null) object stream) + (sys:write-object object stream))) + +#+(or)(defgeneric circle-detection-p (client stream) + (:method (client stream) + (declare (ignore client stream)) + nil)) + +(defgeneric whitespace-char-p (client ch) + (:method ((client null) ch) + (eq (core:syntax-type *readtable* ch) :whitespace))) diff --git a/src/lisp/kernel/lsp/format-pprint.lisp b/src/lisp/kernel/lsp/format-pprint.lisp deleted file mode 100644 index d055ed0ff5..0000000000 --- a/src/lisp/kernel/lsp/format-pprint.lisp +++ /dev/null @@ -1,905 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SYSTEM -*- -;;;; -;;; -*- Package: FORMAT -*- -;;; -;;; ********************************************************************** -;;; This code was written as part of the CMU Common Lisp project at -;;; Carnegie Mellon University, and has been placed in the public domain. -;;; -;;; -;;; ********************************************************************** -;;; -;;; Functions to implement FORMAT and FORMATTER for CMU Common Lisp. -;;; -;;; Written by William Lott, with lots of stuff stolen from the previous -;;; version by David Adam and later rewritten by Bill Maddox. -;;; -;;; Various fixes and adaptations provided by Juan Jose Garcia-Ripoll and -;;; Daniel Kochmański for Embeddable Common-Lisp. -;;; - -(in-package "SYS") - -;;;; Format directive definition macros and runtime support. - -(defmacro expander-pprint-next-arg (string offset) - `(progn - (when (null args) - (error 'format-error - :complaint "No more arguments." - :control-string ,string - :offset ,offset)) - (pprint-pop) - (pop args))) - -;;;; Tab and simple pretty-printing noise. - -(def-format-directive #\T (colonp atsignp params) - (cond (colonp - (check-output-layout-mode 1) - (expand-bind-defaults ((n 1) (m 1)) params - `(pprint-tab ,(if atsignp :section-relative :section) - ,n ,m stream))) - (atsignp - (expand-bind-defaults ((colrel 1) (colinc 1)) params - `(format-relative-tab stream ,colrel ,colinc))) - (t - (expand-bind-defaults ((colnum 1) (colinc 1)) params - `(format-absolute-tab stream ,colnum ,colinc))))) - -(def-format-interpreter #\T (colonp atsignp params) - (cond (colonp - (check-output-layout-mode 1) - (interpret-bind-defaults ((n 1) (m 1)) params - (pprint-tab (if atsignp :section-relative :section) n m stream))) - (atsignp - (interpret-bind-defaults ((colrel 1) (colinc 1)) params - (format-relative-tab stream colrel colinc))) - (t - (interpret-bind-defaults ((colnum 1) (colinc 1)) params - (format-absolute-tab stream colnum colinc))))) - -(defun output-spaces (stream n) - (let ((spaces #.(make-string 100 :initial-element #\space))) - (loop - (when (< n (length spaces)) - (return)) - (write-string spaces stream) - (decf n (length spaces))) - (write-string spaces stream :end n))) - -(defun format-relative-tab (stream colrel colinc) - (if (sys::pretty-stream-p stream) - (pprint-tab :line-relative colrel colinc stream) - (let* ((cur (stream-output-column stream)) - (spaces (if (and cur (plusp colinc)) - (- (* (ceiling (+ cur colrel) colinc) colinc) cur) - colrel))) - (output-spaces stream spaces)))) - -(defun format-absolute-tab (stream colnum colinc) - (if (sys::pretty-stream-p stream) - (pprint-tab :line colnum colinc stream) - (let ((cur (stream-output-column stream))) - (cond ((null cur) - (write-string " " stream)) - ((< cur colnum) - (output-spaces stream (- colnum cur))) - (t - (unless (zerop colinc) - (output-spaces stream - (- colinc (rem (- cur colnum) colinc))))))))) - -(def-format-directive #\_ (colonp atsignp params) - (check-output-layout-mode 1) - (expand-bind-defaults () params - `(pprint-newline ,(if colonp - (if atsignp - :mandatory - :fill) - (if atsignp - :miser - :linear)) - stream))) - -(def-format-interpreter #\_ (colonp atsignp params) - (check-output-layout-mode 1) - (interpret-bind-defaults () params - (pprint-newline (if colonp - (if atsignp - :mandatory - :fill) - (if atsignp - :miser - :linear)) - stream))) - -(def-format-directive #\I (colonp atsignp params) - (check-output-layout-mode 1) - (when atsignp - (error 'format-error - :complaint "Cannot specify the at-sign modifier.")) - (expand-bind-defaults ((n 0)) params - `(pprint-indent ,(if colonp :current :block) ,n stream))) - -(def-format-interpreter #\I (colonp atsignp params) - (check-output-layout-mode 1) - (when atsignp - (error 'format-error - :complaint "Cannot specify the at-sign modifier.")) - (interpret-bind-defaults ((n 0)) params - (pprint-indent (if colonp :current :block) n stream))) - -;;;; Justification. - -(defparameter *illegal-inside-justification* - (mapcar (lambda (x) (parse-directive x 0)) - '("~W" "~:W" "~@W" "~:@W" - "~_" "~:_" "~@_" "~:@_" - "~:>" "~:@>" - "~I" "~:I" "~@I" "~:@I" - "~:T" "~:@T"))) - -(defun check-output-layout-mode (mode) - (when (and *output-layout-mode* - (not (eql *output-layout-mode* mode))) - (error 'format-error - :complaint "Cannot mix ~~W, ~~_, ~~<...~~:>, ~~I, or ~~T with ~~<...~~:;...~~>")) - (setf *output-layout-mode* mode)) - -(defun illegal-inside-justification-p (directive) - (member directive *illegal-inside-justification* - :test (lambda (x y) - (and (format-directive-p x) - (format-directive-p y) - (eql (format-directive-character x) (format-directive-character y)) - (eql (format-directive-colonp x) (format-directive-colonp y)) - (eql (format-directive-atsignp x) (format-directive-atsignp y)))))) - -(def-complex-format-directive #\< (colonp atsignp params string end directives) - (multiple-value-bind - (segments first-semi close remaining) - (parse-format-justification directives) - (values - (if (format-directive-colonp close) - (multiple-value-bind - (prefix per-line-p insides suffix) - (parse-format-logical-block segments colonp first-semi - close params string end) - (expand-format-logical-block prefix per-line-p insides - suffix atsignp)) - (let ((count (reduce #'+ (mapcar (lambda (x) - (count-if #'illegal-inside-justification-p x)) - segments)))) - (when (> count 0) - ;; ANSI specifies that "an error is signalled" in this - ;; situation. - (error 'format-error - :complaint "~D illegal directive~:P found inside justification block" - :arguments (list count))) - (expand-format-justification segments colonp atsignp - first-semi params))) - remaining))) - -(def-complex-format-interpreter #\< - (colonp atsignp params string end directives) - (multiple-value-bind - (segments first-semi close remaining) - (parse-format-justification directives) - (setf args - (if (format-directive-colonp close) - (multiple-value-bind - (prefix per-line-p insides suffix) - (parse-format-logical-block segments colonp first-semi - close params string end) - (interpret-format-logical-block stream orig-args args - prefix per-line-p insides - suffix atsignp)) - (let ((count (reduce #'+ (mapcar (lambda (x) - (count-if #'illegal-inside-justification-p x)) - segments)))) - (when (> count 0) - ;; ANSI specifies that "an error is signalled" in this - ;; situation. - (error 'format-error - :complaint "~D illegal directive~:P found inside justification block" - :arguments (list count))) - (interpret-format-justification stream orig-args args - segments colonp atsignp - first-semi params)))) - remaining)) - -(defun parse-format-justification (directives) - (loop with first-semi = nil - with close = nil - with remaining = directives - for close-or-semi = (find-directive remaining #\> t) - unless close-or-semi - do (error 'format-error - :complaint "No corresponding close bracket.") - collect (let ((posn (position close-or-semi remaining))) - (prog1 (subseq remaining 0 posn) - (setf remaining (nthcdr (1+ posn) remaining)))) - into segments - when (char= (format-directive-character close-or-semi) #\>) - do (setf close close-or-semi) (loop-finish) - unless first-semi - do (setf first-semi close-or-semi) - finally (return (values segments first-semi close remaining)))) - -(defun expand-format-justification (segments colonp atsignp first-semi params) - (let ((newline-segment-p - (and first-semi - (format-directive-colonp first-semi)))) - (when newline-segment-p - (check-output-layout-mode 2)) - (expand-bind-defaults - ((mincol 0) (colinc 1) (minpad 0) (padchar #\space)) - params - `(let ((segments nil) - ,@(when newline-segment-p - '((newline-segment nil) - (extra-space 0) - (line-len 72)))) - (block nil - ,@(when newline-segment-p - `((setf newline-segment - (with-output-to-string (stream) - ,@(expand-directive-list (pop segments)))) - ,(expand-bind-defaults - ((extra 0) - (line-len '(or *print-right-margin* - (gray:stream-line-length stream) - default-line-length))) - (format-directive-params first-semi) - `(setf extra-space ,extra line-len ,line-len)))) - ,@(mapcar #'(lambda (segment) - `(push (with-output-to-string (stream) - ,@(expand-directive-list segment)) - segments)) - segments)) - (format-justification stream - ,@(if newline-segment-p - '(newline-segment extra-space line-len) - '(nil 0 0)) - segments ,colonp ,atsignp - ,mincol ,colinc ,minpad ,padchar))))) - -(defun interpret-format-justification - (stream orig-args args segments colonp atsignp first-semi params) - (interpret-bind-defaults - ((mincol 0) (colinc 1) (minpad 0) (padchar #\space)) - params - (let ((newline-string nil) - (strings nil) - (extra-space 0) - (line-len 0)) - (setf args - (catch 'up-and-out - (when (and first-semi (format-directive-colonp first-semi)) - (check-output-layout-mode 2) - (interpret-bind-defaults - ((extra 0) - (len (or *print-right-margin* - (gray:stream-line-length stream) - default-line-length))) - (format-directive-params first-semi) - (setf newline-string - (with-output-to-string (stream) - (setf args - (interpret-directive-list stream - (pop segments) - orig-args - args)))) - (setf extra-space extra) - (setf line-len len))) - (dolist (segment segments) - (push (with-output-to-string (stream) - (setf args - (interpret-directive-list stream segment - orig-args args))) - strings)) - args)) - (format-justification stream newline-string extra-space line-len strings - colonp atsignp mincol colinc minpad padchar))) - args) - -(defun format-justification (stream newline-prefix extra-space line-len strings - pad-left pad-right mincol colinc minpad padchar) - (setf strings (reverse strings)) - (when (and (not pad-left) (not pad-right) (null (cdr strings))) - (setf pad-left t)) - (let* ((num-gaps (1- (length strings))) - (chars (+ (* num-gaps minpad) - (loop for string in strings summing (length string)))) - (length (if (> chars mincol) - (+ mincol (* (ceiling (- chars mincol) colinc) colinc)) - mincol)) - (padding (- length chars))) - (when (and newline-prefix - (> (+ (or (stream-output-column stream) 0) - length extra-space) - line-len)) - (write-string newline-prefix stream)) - (when pad-left - (incf num-gaps)) - (when pad-right - (incf num-gaps)) - (when (zerop num-gaps) - (incf num-gaps) - (setf pad-left t)) - (flet ((do-padding (border) - (let ((pad-len (truncate padding num-gaps))) - (decf padding pad-len) - (decf num-gaps) - (unless border - (incf pad-len minpad)) - (dotimes (i pad-len) (write-char padchar stream))))) - (when pad-left - (do-padding t)) - (when strings - (write-string (car strings) stream) - (dolist (string (cdr strings)) - (do-padding nil) - (write-string string stream))) - (when pad-right - (do-padding t))))) - -(defun parse-format-logical-block - (segments colonp first-semi close params string end) - (check-output-layout-mode 1) - (when params - (error 'format-error - :complaint "No parameters can be supplied with ~~<...~~:>." - :offset (caar params))) - (multiple-value-bind - (prefix insides suffix) - (multiple-value-bind (prefix-default suffix-default) - (if colonp (values "(" ")") (values "" "")) - (flet ((extract-string (list prefix-p) - (let ((directive (find-if #'format-directive-p list))) - (if directive - (error 'format-error - :complaint - "Cannot include format directives inside the ~ - ~:[suffix~;prefix~] segment of ~~<...~~:>" - :arguments (list prefix-p) - :offset (1- (format-directive-end directive))) - (apply #'concatenate 'string list))))) - (case (length segments) - (0 (values prefix-default nil suffix-default)) - (1 (values prefix-default (car segments) suffix-default)) - (2 (values (extract-string (car segments) t) - (cadr segments) suffix-default)) - (3 (values (extract-string (car segments) t) - (cadr segments) - (extract-string (caddr segments) nil))) - (t - (error 'format-error - :complaint "Too many segments for ~~<...~~:>."))))) - (when (format-directive-atsignp close) - (setf insides - (add-fill-style-newlines insides - string - (if first-semi - (format-directive-end first-semi) - end)))) - (values prefix - (and first-semi (format-directive-atsignp first-semi)) - insides - suffix))) - -(defun add-fill-style-newlines (list string offset &optional last-directive) - (cond - (list - (let ((directive (car list))) - (cond - ((simple-string-p directive) - (let* ((non-space (position #\Space directive :test #'char/=)) - (newlinep (and last-directive - (char= (format-directive-character last-directive) - #\Newline)))) - (cond - ((and newlinep non-space) - (nconc - (list (subseq directive 0 non-space)) - (add-fill-style-newlines-aux - (subseq directive non-space) string (+ offset non-space)) - (add-fill-style-newlines - (cdr list) string (+ offset (length directive))))) - (newlinep - (cons directive - (add-fill-style-newlines - (cdr list) string (+ offset (length directive))))) - (t - (nconc (add-fill-style-newlines-aux directive string offset) - (add-fill-style-newlines - (cdr list) string (+ offset (length directive)))))))) - (t - (cons directive - (add-fill-style-newlines - (cdr list) string - (format-directive-end directive) directive)))))) - (t nil))) - -(defun add-fill-style-newlines-aux (literal string offset) - (loop with end = (length literal) - for posn = 0 then non-blank - for blank = (position #\space literal :start posn) - for non-blank = (if blank - (or (position #\space literal :start blank - :test #'char/=) - end) - nil) - when (null blank) - collect (subseq literal posn) - and do (loop-finish) - until (= posn end) - collect (subseq literal posn non-blank) - collect (make-format-directive - :string string :character #\_ - :start (+ offset non-blank) :end (+ offset non-blank) - :colonp t :atsignp nil :params nil))) - -(defun expand-format-logical-block (prefix per-line-p insides suffix atsignp) - `(let ((arg ,(if atsignp 'args (expand-next-arg)))) - ,@(when atsignp - (setf *only-simple-args* nil) - '((setf args nil))) - (pprint-logical-block - (stream arg - ,(if per-line-p :per-line-prefix :prefix) ,prefix - :suffix ,suffix) - (let ((args arg) - ,@(unless atsignp - `((orig-args arg)))) - (declare (ignorable args ,@(unless atsignp '(orig-args)))) - (block nil - ,@(let ((*expander-next-arg-macro* 'expander-pprint-next-arg) - (*only-simple-args* nil) - (*orig-args-available* (if atsignp *orig-args-available* t))) - (expand-directive-list insides))))))) - -(defun interpret-format-logical-block - (stream orig-args args prefix per-line-p insides suffix atsignp) - (let ((arg (if atsignp args (next-arg)))) - (if per-line-p - (pprint-logical-block - (stream arg :per-line-prefix prefix :suffix suffix) - (let ((*logical-block-popper* #'(lambda () (pprint-pop)))) - (catch 'up-and-out - (interpret-directive-list stream insides - (if atsignp orig-args arg) - arg)))) - (pprint-logical-block (stream arg :prefix prefix :suffix suffix) - (let ((*logical-block-popper* #'(lambda () (pprint-pop)))) - (catch 'up-and-out - (interpret-directive-list stream insides - (if atsignp orig-args arg) - arg)))))) - (if atsignp nil args)) - -(def-complex-format-directive #\> () - (error 'format-error - :complaint "No corresponding open bracket.")) - -;;;; Standard pretty-printing routines. - -(defun pprint-array (stream array) - (cond ((or (and (null *print-array*) (null *print-readably*)) - (stringp array) - (bit-vector-p array)) - (write-ugly-object array stream)) - (*print-readably* - (pprint-raw-array stream array)) - ((vectorp array) - (pprint-vector stream array)) - (t - (pprint-multi-dim-array stream array)))) - -(defun pprint-vector (stream vector) - (write-object-with-circle - vector stream - #'(lambda (vector stream) - (pprint-logical-block (stream nil :prefix "#(" :suffix ")") - (dotimes (i (length vector)) - (unless (zerop i) - (write-char #\space stream) - (pprint-newline :fill stream)) - (pprint-pop) - (write-object (aref vector i) stream)))))) - -(defun pprint-array-contents (stream array) - (declare (array array)) - (labels ((output-guts (stream index dimensions) - (if (null dimensions) - (write-object (row-major-aref array index) stream) - (pprint-logical-block - (stream nil :prefix "(" :suffix ")") - (let ((dim (car dimensions))) - (unless (zerop dim) - (let* ((dims (cdr dimensions)) - (index index) - (step (reduce #'* dims)) - (count 0)) - (loop - (pprint-pop) - (output-guts stream index dims) - (when (= (incf count) dim) - (return)) - (write-char #\space stream) - (pprint-newline (if dims :linear :fill) - stream) - (incf index step))))))))) - (output-guts stream 0 (array-dimensions array)))) - -(defun pprint-multi-dim-array (stream array) - (write-object-with-circle - array stream - #'(lambda (array stream) - (format stream "#~DA" (array-rank array)) - (pprint-array-contents stream array)))) - -(defun pprint-raw-array (stream array) - (write-object-with-circle - array stream - #'(lambda (array stream) - (pprint-logical-block (stream nil :prefix "#A(" :suffix ")") - (write-object (array-element-type array) stream) - (write-char #\Space stream) - (pprint-newline :fill stream) - (write-object (array-dimensions array) stream) - (write-char #\Space stream) - (pprint-newline :fill stream) - (pprint-array-contents stream array))))) - -(defun pprint-lambda-list (stream lambda-list &rest noise) - (declare (ignore noise)) - (pprint-logical-block (stream lambda-list :prefix "(" :suffix ")") - (let ((state :required) - (first t)) - (loop - (pprint-exit-if-list-exhausted) - (unless first - (write-char #\space stream)) - (let ((arg (pprint-pop))) - (unless first - (case arg - (&optional - (setf state :optional) - (pprint-newline :linear stream)) - ((&rest &body) - (setf state :required) - (pprint-newline :linear stream)) - (&key - (setf state :key) - (pprint-newline :linear stream)) - (&aux - (setf state :optional) - (pprint-newline :linear stream)) - (t - (pprint-newline :fill stream)))) - (ecase state - (:required - (pprint-lambda-list stream arg)) - ((:optional :key) - (pprint-logical-block - (stream arg :prefix "(" :suffix ")") - (pprint-exit-if-list-exhausted) - (if (eq state :key) - (pprint-logical-block - (stream (pprint-pop) :prefix "(" :suffix ")") - (pprint-exit-if-list-exhausted) - (write-object (pprint-pop) stream) - (pprint-exit-if-list-exhausted) - (write-char #\space stream) - (pprint-newline :fill stream) - (pprint-lambda-list stream (pprint-pop)) - (loop - (pprint-exit-if-list-exhausted) - (write-char #\space stream) - (pprint-newline :fill stream) - (write-object (pprint-pop) stream))) - (pprint-lambda-list stream (pprint-pop))) - (loop - (pprint-exit-if-list-exhausted) - (write-char #\space stream) - (pprint-newline :linear stream) - (write-object (pprint-pop) stream)))))) - (setf first nil))))) - -(defun pprint-lambda (stream list &rest noise) - (declare (ignore noise)) - (format stream "~:<~^~W~^~3I ~:_~/SI:PPRINT-LAMBDA-LIST/~1I~@{ ~_~W~}~:>" list)) - -(defun pprint-block (stream list &rest noise) - (declare (ignore noise)) - (format stream "~:<~^~W~^~3I ~:_~W~1I~@{ ~_~W~}~:>" list)) - -(defun pprint-flet (stream list &rest noise) - (declare (ignore noise)) - (if (and (consp list) - (consp (cdr list)) - (not (null (cddr list)))) - (format stream - "~:<~^~W~^ ~@_~:<~@{~:<~^~W~^~3I ~:_~/SI:PPRINT-LAMBDA-LIST/~1I~:@_~@{~W~^ ~_~}~:>~^ ~_~}~:>~1I~@:_~@{~W~^ ~_~}~:>" - list) - ;; Things like (labels foo) function names. - (pprint-logical-block (stream list :prefix "(" :suffix ")") - (pprint-exit-if-list-exhausted) - (write (pprint-pop) :stream stream) - (loop (pprint-exit-if-list-exhausted) - (write-char #\Space stream) - (write (pprint-pop) :stream stream))))) - -(defun pprint-let (stream list &rest noise) - (declare (ignore noise)) - (format stream - "~:<~^~W~^ ~@_~:<~@{~:<~^~W~@{ ~_~W~}~:>~^ ~_~}~:>~1I~:@_~@{~W~^ ~_~}~:>" - list)) - -(defun pprint-progn (stream list &rest noise) - (declare (ignore noise)) - (format stream "~:<~^~W~@{ ~_~W~}~:>" list)) - -(defun pprint-progv (stream list &rest noise) - (declare (ignore noise)) - (format stream "~:<~^~W~^~3I ~_~W~^ ~_~W~^~1I~@{ ~_~W~}~:>" - list)) - -(defun pprint-quote (stream list &rest noise) - (declare (ignore noise)) - (cond ((or (not (consp list)) - (not (consp (cdr list))) - (cddr list)) - (pprint-fill stream list)) - ((eq (car list) 'function) - (write-string "#'" stream) - (write-object (cadr list) stream)) - ((eq (car list) 'quote) - (write-char #\' stream) - (write-object (cadr list) stream)) - ((eq (car list) 'core:quasiquote) - (let ((core:*quasiquote* (list* (target-stream stream) t - core:*quasiquote*))) - (write-char #\` stream) - (write-object (cadr list) stream))) - ((not (getf core:*quasiquote* (target-stream stream))) - (pprint-fill stream list)) - ((eq (car list) 'core:unquote) - (let ((core:*quasiquote* (list* (target-stream stream) nil - core:*quasiquote*))) - (write-char #\, stream) - (write-object (cadr list) stream))) - ((eq (car list) 'core:unquote-splice) - (let ((core:*quasiquote* (list* (target-stream stream) nil - core:*quasiquote*))) - (write-string ",@" stream) - (write-object (cadr list) stream))) - ((eq (car list) 'core:unquote-nsplice) - (let ((core:*quasiquote* (list* (target-stream stream) nil - core:*quasiquote*))) - (write-string ",." stream) - (write-object (cadr list) stream))) - (t - (pprint-fill stream list)))) - -(defun pprint-setq (stream list &rest noise) - (declare (ignore noise)) - (pprint-logical-block (stream list :prefix "(" :suffix ")") - (pprint-exit-if-list-exhausted) - (write-object (pprint-pop) stream) - (pprint-exit-if-list-exhausted) - (write-char #\space stream) - (pprint-newline :miser stream) - (if (and (consp (cdr list)) (consp (cddr list))) - (loop - (pprint-indent :current 2 stream) - (write-object (pprint-pop) stream) - (pprint-exit-if-list-exhausted) - (write-char #\space stream) - (pprint-newline :linear stream) - (pprint-indent :current -2 stream) - (write-object (pprint-pop) stream) - (pprint-exit-if-list-exhausted) - (write-char #\space stream) - (pprint-newline :linear stream)) - (progn - (pprint-indent :current 0 stream) - (write-object (pprint-pop) stream) - (pprint-exit-if-list-exhausted) - (write-char #\space stream) - (pprint-newline :linear stream) - (write-object (pprint-pop) stream))))) - -(defmacro pprint-tagbody-guts (stream) - `(loop - (pprint-exit-if-list-exhausted) - (write-char #\space ,stream) - (let ((form-or-tag (pprint-pop))) - (pprint-indent :block - (if (atom form-or-tag) 0 1) - ,stream) - (pprint-newline :linear ,stream) - (write-object form-or-tag ,stream)))) - -(defun pprint-tagbody (stream list &rest noise) - (declare (ignore noise)) - (pprint-logical-block (stream list :prefix "(" :suffix ")") - (pprint-exit-if-list-exhausted) - (write-object (pprint-pop) stream) - (pprint-tagbody-guts stream))) - -(defun pprint-case (stream list &rest noise) - (declare (ignore noise)) - (format stream - "~:<~^~W~^ ~3I~:_~W~1I~@{ ~_~:<~^~:/SI:PPRINT-FILL/~^~@{ ~_~W~}~:>~}~:>" - list)) - -(defun pprint-defun (stream list &rest noise) - (declare (ignore noise)) - (format stream - "~:<~^~W~^ ~@_~:I~W~^ ~:_~/SI:PPRINT-LAMBDA-LIST/~1I~@{ ~_~W~}~:>" - list)) - -(defun pprint-destructuring-bind (stream list &rest noise) - (declare (ignore noise)) - (format stream - "~:<~^~W~^~3I ~_~:/SI:PPRINT-LAMBDA-LIST/~^ ~_~W~^~1I~@{ ~_~W~}~:>" - list)) - -(defun pprint-do (stream list &rest noise) - (declare (ignore noise)) - (pprint-logical-block (stream list :prefix "(" :suffix ")") - (pprint-exit-if-list-exhausted) - (write-object (pprint-pop) stream) - (pprint-exit-if-list-exhausted) - (write-char #\space stream) - (pprint-indent :current 0 stream) - (format stream "~:<~@{~:<~^~W~^ ~@_~:I~W~@{ ~_~W~}~:>~^~:@_~}~:>" - (pprint-pop)) - (pprint-exit-if-list-exhausted) - (write-char #\space stream) - (pprint-newline :linear stream) - (pprint-linear stream (pprint-pop)) - (pprint-tagbody-guts stream))) - -(defun pprint-dolist (stream list &rest noise) - (declare (ignore noise)) - (pprint-logical-block (stream list :prefix "(" :suffix ")") - (pprint-exit-if-list-exhausted) - (write-object (pprint-pop) stream) - (pprint-exit-if-list-exhausted) - (pprint-indent :block 3 stream) - (write-char #\space stream) - (pprint-newline :fill stream) - (format stream "~:<~^~W~^ ~:_~:I~W~@{ ~_~W~}~:>" - (pprint-pop)) - (pprint-tagbody-guts stream))) - -(defun pprint-typecase (stream list &rest noise) - (declare (ignore noise)) - (format stream - "~:<~^~W~^ ~3I~:_~W~1I~@{ ~_~:<~^~W~^~@{ ~_~W~}~:>~}~:>" - list)) - -(defun pprint-prog (stream list &rest noise) - (declare (ignore noise)) - (pprint-logical-block (stream list :prefix "(" :suffix ")") - (pprint-exit-if-list-exhausted) - (write-object (pprint-pop) stream) - (pprint-exit-if-list-exhausted) - (write-char #\space stream) - (pprint-newline :miser stream) - (pprint-fill stream (pprint-pop)) - (pprint-tagbody-guts stream))) - -(defun pprint-function-call (stream list &rest noise) - (declare (ignore noise)) - (format stream "~:<~^~W~^ ~:_~:I~@{~W~^ ~_~}~:>" list)) - - -;;;; Interface seen by regular (ugly) printer and initialization routines. - -(progn - (let ((*print-pprint-dispatch* (make-pprint-dispatch-table))) - ;; Printers for regular types. - (set-pprint-dispatch 'array #'pprint-array) - (set-pprint-dispatch '(cons (and symbol (satisfies fboundp))) - #'pprint-function-call -1) - (set-pprint-dispatch 'cons #'pprint-fill -2) - ;; Cons cells with interesting things for the car. - (loop for (operator f) - in '((lambda pprint-lambda) - ;; Special forms. - (block pprint-block) - (catch pprint-block) - (compiler-let pprint-let) - (eval-when pprint-block) - (flet pprint-flet) - (function pprint-quote) - (labels pprint-flet) - (let pprint-let) - (let* pprint-let) - (locally pprint-progn) - (macrolet pprint-flet) - (multiple-value-call pprint-block) - (multiple-value-prog1 pprint-block) - (progn pprint-progn) - (progv pprint-progv) - (quote pprint-quote) - (return-from pprint-block) - (setq pprint-setq) - (symbol-macrolet pprint-let) - (tagbody pprint-tagbody) - (throw pprint-block) - (unwind-protect pprint-block) - (core:quasiquote pprint-quote) - (core:unquote pprint-quote) - (core:unquote-splice pprint-quote) - (core:unquote-nsplice pprint-quote) - - ;; Macros. - (case pprint-case) - (ccase pprint-case) - (ctypecase pprint-typecase) - (defconstant pprint-block) - (define-modify-macro pprint-defun) - (define-setf-expander pprint-defun) - (defmacro pprint-defun) - (defparameter pprint-block) - (defsetf pprint-defun) - (defstruct pprint-block) - (deftype pprint-defun) - (defun pprint-defun) - (defvar pprint-block) - (destructuring-bind pprint-destructuring-bind) - (do pprint-do) - (do* pprint-do) - (do-all-symbols pprint-dolist) - (do-external-symbols pprint-dolist) - (do-symbols pprint-dolist) - (dolist pprint-dolist) - (dotimes pprint-dolist) - (ecase pprint-case) - (etypecase pprint-typecase) - #+nil (handler-bind ...) - #+nil (handler-case ...) - #+nil (loop ...) - (multiple-value-bind pprint-progv) - (multiple-value-setq pprint-block) - (pprint-logical-block pprint-block) - (print-unreadable-object pprint-block) - (prog pprint-prog) - (prog* pprint-prog) - (prog1 pprint-block) - (prog2 pprint-progv) - (psetf pprint-setq) - (psetq pprint-setq) - #+nil (restart-bind ...) - #+nil (restart-case ...) - (setf pprint-setq) - (step pprint-progn) - (time pprint-progn) - (typecase pprint-typecase) - (unless pprint-block) - (when pprint-block) - (with-compilation-unit pprint-block) - #+nil (with-condition-restarts ...) - (with-hash-table-iterator pprint-block) - (with-input-from-string pprint-block) - (with-open-file pprint-block) - (with-open-stream pprint-block) - (with-output-to-string pprint-block) - (with-package-iterator pprint-block) - (with-simple-restart pprint-block) - (with-standard-io-syntax pprint-progn)) - do (set-pprint-dispatch `(cons (eql ,operator)) - (symbol-function f))) - (setf *initial-pprint-dispatch* *print-pprint-dispatch*) - ) - (setf *print-pprint-dispatch* (copy-pprint-dispatch nil) - *standard-pprint-dispatch* *initial-pprint-dispatch*) - (setf (pprint-dispatch-table-read-only-p *standard-pprint-dispatch*) t) - (setf (first (cdr si::+io-syntax-progv-list+)) *standard-pprint-dispatch*) - (setf *print-pretty* t)) diff --git a/src/lisp/kernel/lsp/format.lisp b/src/lisp/kernel/lsp/format.lisp deleted file mode 100644 index 1bba9edd30..0000000000 --- a/src/lisp/kernel/lsp/format.lisp +++ /dev/null @@ -1,2510 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SYSTEM -*- -;;;; -;;; -*- Package: FORMAT -*- -;;; -;;; ********************************************************************** -;;; This code was written as part of the CMU Common Lisp project at -;;; Carnegie Mellon University, and has been placed in the public domain. -;;; -;;; -;;; ********************************************************************** -;;; -;;; Functions to implement FORMAT and FORMATTER for CMU Common Lisp. -;;; -;;; Written by William Lott, with lots of stuff stolen from the previous -;;; version by David Adam and later rewritten by Bill Maddox. -;;; -;;; Various fixes and adaptations provided by Juan Jose Garcia-Ripoll and -;;; Daniel Kochmański for Embeddable Common-Lisp. -;;; - -(in-package "SYS") - -(pushnew :cdr-7 *features*) - -;;;; Float printing. - -;;; -;;; Written by Bill Maddox -;;; -;;; -;;; -;;; FLONUM-TO-STRING (and its subsidiary function FLOAT-STRING) does most of -;;; the work for all printing of floating point numbers in the printer and in -;;; FORMAT. It converts a floating point number to a string in a free or -;;; fixed format with no exponent. The interpretation of the arguments is as -;;; follows: -;;; -;;; X - The floating point number to convert, which must not be -;;; negative. -;;; WIDTH - The preferred field width, used to determine the number -;;; of fraction digits to produce if the FDIGITS parameter -;;; is unspecified or NIL. If the non-fraction digits and the -;;; decimal point alone exceed this width, no fraction digits -;;; will be produced unless a non-NIL value of FDIGITS has been -;;; specified. Field overflow is not considerd an error at this -;;; level. -;;; FDIGITS - The number of fractional digits to produce. Insignificant -;;; trailing zeroes may be introduced as needed. May be -;;; unspecified or NIL, in which case as many digits as possible -;;; are generated, subject to the constraint that there are no -;;; trailing zeroes. -;;; SCALE - If this parameter is specified or non-zero, then the number -;;; printed is (* x (expt 10 scale)). This scaling is exact, -;;; and cannot lose precision. -;;; FMIN - This parameter, if specified or non-zero, is the minimum -;;; number of fraction digits which will be produced, regardless -;;; of the value of WIDTH or FDIGITS. This feature is used by -;;; the ~E format directive to prevent complete loss of -;;; significance in the printed value due to a bogus choice of -;;; scale factor. -;;; -;;; Most of the optional arguments are for the benefit for FORMAT and are not -;;; used by the printer. -;;; -;;; Returns: -;;; (VALUES DIGIT-STRING DIGIT-LENGTH LEADING-POINT TRAILING-POINT DECPNT) -;;; where the results have the following interpretation: -;;; -;;; DIGIT-STRING - The decimal representation of X, with decimal point. -;;; DIGIT-LENGTH - The length of the string DIGIT-STRING. -;;; LEADING-POINT - True if the first character of DIGIT-STRING is the -;;; decimal point. -;;; TRAILING-POINT - True if the last character of DIGIT-STRING is the -;;; decimal point. -;;; POINT-POS - The position of the digit preceding the decimal -;;; point. Zero indicates point before first digit. -;;; -;;; NOTE: FLONUM-TO-STRING goes to a lot of trouble to guarantee accuracy. -;;; Specifically, the decimal number printed is the closest possible -;;; approximation to the true value of the binary number to be printed from -;;; among all decimal representations with the same number of digits. In -;;; free-format output, i.e. with the number of digits unconstrained, it is -;;; guaranteed that all the information is preserved, so that a properly- -;;; rounding reader can reconstruct the original binary number, bit-for-bit, -;;; from its printed decimal representation. Furthermore, only as many digits -;;; as necessary to satisfy this condition will be printed. -;;; -;;; -;;; FLOAT-STRING actually generates the digits for positive numbers. The -;;; algorithm is essentially that of algorithm Dragon4 in "How to Print -;;; Floating-Point Numbers Accurately" by Steele and White. The current -;;; (draft) version of this paper may be found in [CMUC]tradix.press. -;;; DO NOT EVEN THINK OF ATTEMPTING TO UNDERSTAND THIS CODE WITHOUT READING -;;; THE PAPER! - -(defparameter *digits* "0123456789") - -(defun float-to-digits* (digits number position relativep) - "Does what float-to-digits does, but also detects if result is zero." - (multiple-value-bind (exp string) - (float-to-digits digits - number - position - relativep) - (values exp - string - (and position - (< exp (- (abs position))))))) - -(defun flonum-to-string (x &optional width fdigits (scale 0) (fmin 0)) - (declare (type float x)) - (if (zerop x) - ;; Zero is a special case which FLOAT-STRING cannot handle. - (cond ((null fdigits) (values ".0" 2 t nil 0)) - ((zerop fdigits) (values "0." 2 nil t 1)) - (T (let ((s (make-string (1+ fdigits) :initial-element #\0))) - (setf (schar s 0) #\.) - (values s (length s) t nil 0)))) - (multiple-value-bind (e string zero?) - (cond (fdigits - (float-to-digits* nil x - (min (- (+ fdigits scale)) - (- (+ fmin scale))) - nil)) - ((null width) - (float-to-digits* nil x nil nil)) - (T (let ((w (multiple-value-list - (float-to-digits* nil x - (max 0 - (+ (- width 2) - (if (minusp scale) - scale 0))) - t))) - (f (multiple-value-list - (float-to-digits* nil x - (- (+ fmin scale)) - nil)))) - (if (>= (length (cadr w)) - (length (cadr f))) - (values-list w) - (values-list f))))) - (let* ((exp (+ e scale)) - (stream (make-string-output-stream)) - (length (length string))) - ;; Integer part - (when (plusp exp) - (write-string string - stream - :end (min length exp)) - (dotimes (i (- exp length)) - (write-char #\0 stream))) - ;; Separator and fraction - (write-char #\. stream) - ;; Fraction part - (cond ((and zero? fdigits) - (dotimes (i fdigits) - (write-char #\0 stream))) - (fdigits - (let ((characters-used 0)) - (dotimes (i (min (- exp) fdigits)) - (incf characters-used) - (write-char #\0 stream)) - (let* ((start (max 0 (min length exp))) - (end (max start - (min length - (+ start (- fdigits characters-used)))))) - (write-string string stream - :start start - :end end) - (incf characters-used (- end start)) - (dotimes (i (- fdigits characters-used)) - (write-char #\0 stream))))) - (zero? - (write-char #\0 stream)) - (T - (dotimes (i (- exp)) - (write-char #\0 stream)) - (let ((start (max 0 (min length exp)))) - (write-string string stream - :start start)))) - (let* ((string (get-output-stream-string stream)) - (length (length string)) - (position (position #\. string))) - (values string - length - (= position 0) - (= position (1- length)) - position)))))) - -(defun exponent-in-base10 (x) - (if (= x 0) - 1 - (1+ (floor (log (abs x) 10))))) - -(defstruct (format-directive - (:print-function %print-format-directive)) - (string t :type simple-string) - (start 0 :type (and unsigned-byte fixnum)) - (end 0 :type (and unsigned-byte fixnum)) - (character #\Space :type base-char) - (colonp nil :type (member t nil)) - (atsignp nil :type (member t nil)) - (params nil :type list)) - -(defun %print-format-directive (struct stream depth) - (declare (ignore depth)) - (print-unreadable-object (struct stream) - (write-string (format-directive-string struct) stream - :start (format-directive-start struct) - :end (format-directive-end struct)))) - -(defconstant +format-directive-limit+ (1+ (char-code #\~))) - -(defparameter *format-directive-expanders* - (make-array +format-directive-limit+ :initial-element nil)) -(defparameter *format-directive-interpreters* - (make-array +format-directive-limit+ :initial-element nil)) - -(defparameter *default-format-error-control-string* nil) -(defparameter *default-format-error-offset* nil) - -;; If this flag is 1, directives ~W, ~_, ~<...~:>, ~I or ~T were found. -;; If the flag is 2, directive ~<...~:;...~> was found. -;; NIL otherwise. -(defparameter *output-layout-mode* nil) - -(define-condition format-error (simple-error) - ((format-control :initarg :complaint) - (format-arguments :initarg :arguments) - (control-string :reader format-error-control-string - :initarg :control-string - :initform *default-format-error-control-string*) - (offset :reader format-error-offset :initarg :offset - :initform *default-format-error-offset*) - (print-banner :reader format-error-print-banner :initarg :print-banner - :initform t)) - (:report (lambda (condition stream) - (format - stream - "~:[~;Error in format: ~]~ - ~?~@[~% ~A~% ~V@T^~]" - (format-error-print-banner condition) - (simple-condition-format-control condition) - (simple-condition-format-arguments condition) - (format-error-control-string condition) - (format-error-offset condition))))) - - -;;;; TOKENIZE-CONTROL-STRING - -(defun tokenize-control-string (string) - (declare (simple-string string)) - (let ((index 0) - (end (length string)) - (result nil)) - (loop - (let ((next-directive (or (position #\~ string :start index) end))) - (when (> next-directive index) - (push (subseq string index next-directive) result)) - (when (= next-directive end) - (return)) - (let ((directive (parse-directive string next-directive))) - (push directive result) - (setf index (format-directive-end directive))))) - (nreverse result))) - -(defun parse-directive (string start) - (declare (simple-string string)) - (let ((posn (1+ start)) (params nil) (colonp nil) (atsignp nil) - (end (length string))) - (flet ((get-char () - (if (= posn end) - (error 'format-error - :complaint "String ended before directive was found." - :control-string string - :offset start) - (schar string posn)))) - (loop - (let ((char (get-char))) - (cond ((and (not colonp) (not atsignp) - (or (char<= #\0 char #\9) (char= char #\+) (char= char #\-))) - (multiple-value-bind - (param new-posn) - (parse-integer string :start posn :junk-allowed t) - (push (cons posn param) params) - (setf posn new-posn) - (case (get-char) - (#\,) - ((#\: #\@) - (decf posn)) - (t - (return))))) - ((and (not colonp) (not atsignp) - (or (char= char #\v) (char= char #\V))) - (push (cons posn :arg) params) - (incf posn) - (case (get-char) - (#\,) - ((#\: #\@) - (decf posn)) - (t - (return)))) - ((and (not colonp) (not atsignp) - (char= char #\#)) - (push (cons posn :remaining) params) - (incf posn) - (case (get-char) - (#\,) - ((#\: #\@) - (decf posn)) - (t - (return)))) - ((and (not colonp) (not atsignp) - (char= char #\')) - (incf posn) - (push (cons posn (get-char)) params) - (incf posn) - (unless (char= (get-char) #\,) - (decf posn))) - ((and (not colonp) (not atsignp) - (char= char #\,)) - (push (cons posn nil) params)) - ((char= char #\:) - (if colonp - (error 'format-error - :complaint "Too many colons supplied." - :control-string string - :offset posn) - (setf colonp t))) - ((char= char #\@) - (if atsignp - (error 'format-error - :complaint "Too many at-signs supplied." - :control-string string - :offset posn) - (setf atsignp t))) - (t - (return)))) - (incf posn)) - (let ((char (get-char))) - (when (char= char #\/) - (let ((closing-slash (position #\/ string :start (1+ posn)))) - (if closing-slash - (setf posn closing-slash) - (error 'format-error - :complaint "No matching closing slash." - :control-string string - :offset posn)))) - (make-format-directive - :string string :start start :end (1+ posn) - :character (char-upcase char) - :colonp colonp :atsignp atsignp - :params (nreverse params)))))) - - -;;;; Specials used to communicate information. - -;;; *UP-UP-AND-OUT-ALLOWED* -- internal. -;;; -;;; Used both by the expansion stuff and the interpreter stuff. When it is -;;; non-NIL, up-up-and-out (~:^) is allowed. Otherwise, ~:^ isn't allowed. -;;; -(defparameter *up-up-and-out-allowed* nil) - -;;; *LOGICAL-BLOCK-POPPER* -- internal. -;;; -;;; Used by the interpreter stuff. When it non-NIL, its a function that will -;;; invoke PPRINT-POP in the right lexical environemnt. -;;; -(defparameter *logical-block-popper* nil) - -;;; *EXPANDER-NEXT-ARG-MACRO* -- internal. -;;; -;;; Used by the expander stuff. This is bindable so that ~<...~:> -;;; can change it. -;;; -(defparameter *expander-next-arg-macro* 'expander-next-arg) - -;;; *ONLY-SIMPLE-ARGS* -- internal. -;;; -;;; Used by the expander stuff. Initially starts as T, and gets set to NIL -;;; if someone needs to do something strange with the arg list (like use -;;; the rest, or something). -;;; -(defvar *only-simple-args*) - -;;; *ORIG-ARGS-AVAILABLE* -- internal. -;;; -;;; Used by the expander stuff. We do an initial pass with this as NIL. -;;; If someone doesn't like this, they (throw 'need-orig-args nil) and we try -;;; again with it bound to T. If this is T, we don't try to do anything -;;; fancy with args. -;;; -(defparameter *orig-args-available* nil) - -;;; *SIMPLE-ARGS* -- internal. -;;; -;;; Used by the expander stuff. List of (symbol . offset) for simple args. -;;; -(defvar *simple-args*) - - - - -;;;; FORMAT - -;;#-ecl -(defun format-std (destination control-string &rest format-arguments) - "Provides various facilities for formatting output. - CONTROL-STRING contains a string to be output, possibly with embedded - directives, which are flagged with the escape character \"~\". Directives - generally expand into additional text to be output, usually consuming one - or more of the FORMAT-ARGUMENTS in the process. A few useful directives - are: - ~A or ~nA Prints one argument as if by PRINC - ~S or ~nS Prints one argument as if by PRIN1 - ~D or ~nD Prints one argument as a decimal integer - ~% Does a TERPRI - ~& Does a FRESH-LINE - - where n is the width of the field in which the object is printed. - - DESTINATION controls where the result will go. If DESTINATION is T, then - the output is sent to the standard output stream. If it is NIL, then the - output is returned in a string as the value of the call. Otherwise, - DESTINATION must be a stream to which the output will be sent. - - Example: (FORMAT NIL \"The answer is ~D.\" 10) => \"The answer is 10.\" - - FORMAT has many additional capabilities not described here. Consult - Section 22.3 (Formatted Output) of the ANSI Common Lisp standard for - details." - (etypecase destination - (null - (with-output-to-string (stream) - (formatter-aux stream control-string format-arguments))) - (string - (with-output-to-string (stream destination) - (formatter-aux stream control-string format-arguments))) - ((member t) - (formatter-aux *standard-output* control-string format-arguments) - nil) - (stream - (formatter-aux destination control-string format-arguments) - nil))) - -(defun formatter-aux (stream string-or-fun orig-args &optional (args orig-args)) - (if (functionp string-or-fun) - (apply string-or-fun stream args) - (catch 'up-and-out - (let* ((string (etypecase string-or-fun - (simple-string - string-or-fun) - (string - (coerce string-or-fun 'simple-string)))) - (*output-layout-mode* nil) - (*default-format-error-control-string* string) - (*logical-block-popper* nil)) - (interpret-directive-list stream (tokenize-control-string string) - orig-args args))))) - -(defun interpret-directive-list (stream directives orig-args args) - (if directives - (let ((directive (car directives))) - (etypecase directive - (simple-string - (write-string directive stream) - (interpret-directive-list stream (cdr directives) orig-args args)) - (format-directive - (multiple-value-bind - (new-directives new-args) - (let* ((code (char-code (format-directive-character directive))) - (function - (and (< code +format-directive-limit+) - (svref *format-directive-interpreters* code))) - (*default-format-error-offset* - (1- (format-directive-end directive)))) - (unless function - (error 'format-error - :complaint (format nil "Unknown format directive (~a) in (~a)." directive directives ))) - (multiple-value-bind - (new-directives new-args) - (funcall function stream directive - (cdr directives) orig-args args) - (values new-directives new-args))) - (interpret-directive-list stream new-directives - orig-args new-args))))) - args)) - - -;;;; FORMATTER - -(defmacro formatter (control-string) - `#',(%formatter control-string)) - -(defun %formatter (control-string) - (multiple-value-bind (guts variables) - (%formatter-guts control-string) - (%formatter-lambda control-string guts variables))) - -(defun %formatter-lambda (control-string guts variables) - (if (eq variables 't) - ;; need the original args - `(lambda (stream &rest orig-args) - (let ((args orig-args)) - ,guts - args)) - ;; happy day, we can use simple args - `(lambda (stream - &optional ,@(simple-formatter-params - control-string variables) - &rest args) - ,guts - args))) - -;;; Return (values form variables), where variables is either -;;; a list of (symbol . offset) entries, or T if orig-args are required. -(defun %formatter-guts (control-string) - ;; First try without the original args. - (catch 'need-orig-args - (let* ((*simple-args* nil) (*only-simple-args* t) - (guts (expand-control-string control-string))) - (return-from %formatter-guts - (values guts (nreverse *simple-args*))))) - ;; Failing that, - (let ((*orig-args-available* t) - (*only-simple-args* nil)) - (values (expand-control-string control-string) t))) - -(defun simple-formatter-params (control-string args) - (mapcar (lambda (arg) (simple-formatter-param control-string arg)) - args)) - -;;; Return an optional parameter corresponding to a simple arg. -(defun simple-formatter-param (control-string arg) - `(,(car arg) - ,(simple-formatter-param-err-form control-string (cdr arg)))) - -(defun simple-formatter-param-err-form (control-string offset) - `(error 'format-error - :complaint "Required argument missing" - :control-string ,control-string - :offset ,offset)) - -(defun expand-control-string (string) - (let* ((string (etypecase string - (simple-string - string) - (string - (coerce string 'simple-string)))) - (*output-layout-mode* nil) - (*default-format-error-control-string* string) - (directives (tokenize-control-string string))) - `(block nil - ,@(expand-directive-list directives)))) - -(defun expand-directive-list (directives) - (let ((results nil) - (remaining-directives directives)) - (loop - (unless remaining-directives - (return)) - (multiple-value-bind - (form new-directives) - (expand-directive (car remaining-directives) - (cdr remaining-directives)) - (when form - (push form results)) - (setf remaining-directives new-directives))) - (reverse results))) - -(defun expand-directive (directive more-directives) - (etypecase directive - (simple-string - (values `(write-string ,directive stream) - more-directives)) - (format-directive - (let* ((code (char-code (format-directive-character directive))) - (expander - (and (< code +format-directive-limit+) - (svref *format-directive-expanders* code))) - (*default-format-error-offset* - (1- (format-directive-end directive)))) - (if expander - (funcall expander directive more-directives) - (error 'format-error - :complaint "Unknown directive.")))))) - -(defun expand-next-arg (&optional offset) - (if (or *orig-args-available* (not *only-simple-args*)) - `(,*expander-next-arg-macro* - ,*default-format-error-control-string* - ,(or offset *default-format-error-offset*)) - (let ((symbol (gensym "FORMAT-ARG-"))) - (push (cons symbol (or offset *default-format-error-offset*)) - *simple-args*) - symbol))) - - -;;;; Format directive definition macros and runtime support. - -(defmacro expander-next-arg (string offset) - `(if args - (pop args) - (error 'format-error - :complaint "No more arguments." - :control-string ,string - :offset ,offset))) - -;;; NEXT-ARG -- internal. -;;; -;;; This macro is used to extract the next argument from the current arg list. -;;; This is the version used by format directive interpreters. -;;; -(defmacro next-arg (&optional offset) - `(progn - (when (null args) - (error 'format-error - :complaint "No more arguments." - ,@(when offset - `(:offset ,offset)))) - (when *logical-block-popper* - (funcall *logical-block-popper*)) - (pop args))) - -(defmacro def-complex-format-directive (char lambda-list &body body) - (let* ((name (or (char-name char) (string char))) - (defun-name (intern (concatenate 'string name "-FORMAT-DIRECTIVE-EXPANDER"))) - (directive (gensym)) - (directives (if lambda-list (car (last lambda-list)) (gensym)))) - `(%set-format-directive-expander - ,char - #'(lambda (,directive ,directives) - (declare (core::lambda-name ,defun-name)) - ,@(if lambda-list - `((let ,(mapcar #'(lambda (var) - `(,var - (,(intern (concatenate - 'string - "FORMAT-DIRECTIVE-" - (symbol-name var)) - (symbol-package 'foo)) - ,directive))) - (butlast lambda-list)) - ,@body)) - `((declare (ignore ,directive ,directives)) - ,@body)))))) - -(defmacro def-format-directive (char lambda-list &body body) - (let ((directives (gensym)) - (declarations nil) - (body-without-decls body)) - (loop - (let ((form (car body-without-decls))) - (unless (and (consp form) (eq (car form) 'declare)) - (return)) - (push (pop body-without-decls) declarations))) - (setf declarations (reverse declarations)) - `(def-complex-format-directive ,char (,@lambda-list ,directives) - ,@declarations - (values (progn ,@body-without-decls) - ,directives)))) - -(defmacro expand-bind-defaults (specs params &body body) - (once-only ((params params)) - (if specs - (loop for (var default) in specs - for symbol = (gensym) - collect `(,var ',symbol) into expander-bindings - collect `(list ',symbol - (let* ((param-and-offset (pop ,params)) - (offset (car param-and-offset)) - (param (cdr param-and-offset))) - (case param - (:arg `(or ,(expand-next-arg offset) - ,,default)) - (:remaining - (setf *only-simple-args* nil) - '(length args)) - ((nil) ,default) - (t param)))) - into runtime-bindings - finally (return - `(let ,expander-bindings - `(let ,(list ,@runtime-bindings) - ,@(if ,params - (error 'format-error - :complaint - "Too many parameters, expected no more than ~D" - :arguments (list ,(length specs)) - :offset (caar ,params))) - ,,@body)))) - `(progn - (when ,params - (error 'format-error - :complaint "Too many parameters, expected no more than 0" - :offset (caar ,params))) - ,@body)))) - -(defmacro def-complex-format-interpreter (char lambda-list &body body) - (let* ((directive (gensym)) - (directives (if lambda-list (car (last lambda-list)) (gensym))) - (name (or (char-name char) (string char))) - (defun-name (intern (concatenate 'string name "-FORMAT-INTERPRETER")))) - `(%set-format-directive-interpreter ,char - (lambda (stream ,directive ,directives orig-args args) - (declare (ignorable stream orig-args args) (core:lambda-name ,defun-name)) - ,@(if lambda-list - `((let ,(mapcar #'(lambda (var) - `(,var - (,(intern (concatenate - 'string - "FORMAT-DIRECTIVE-" - (symbol-name var)) - (symbol-package 'foo)) - ,directive))) - (butlast lambda-list)) - (values (progn ,@body) args))) - `((declare (ignore ,directive ,directives)) - ,@body)))))) - -(defmacro def-format-interpreter (char lambda-list &body body) - (let ((directives (gensym))) - `(def-complex-format-interpreter ,char (,@lambda-list ,directives) - ,@body - ,directives))) - -(defmacro interpret-bind-defaults (specs params &body body) - (once-only ((params params)) - `(let* ,(loop for (var default) in specs - collect `(,var (let* ((param-and-offset (pop ,params)) - (offset (car param-and-offset)) - (param (cdr param-and-offset))) - (case param - (:arg (or (next-arg offset) ,default)) - (:remaining (length args)) - ((nil) ,default) - (t param))))) - (when ,params - (error 'format-error - :complaint - "Too many parameters, expected no more than ~D" - :arguments (list ,(length specs)) - :offset (caar ,params))) - ,@body))) - -(defun %set-format-directive-expander (char fn) - (setf (aref *format-directive-expanders* (char-code (char-upcase char))) fn) - char) - -(defun %set-format-directive-interpreter (char fn) - (setf (aref *format-directive-interpreters* - (char-code (char-upcase char))) - fn) - char) - -(defun find-directive (directives kind stop-at-semi) - (if directives - (let ((next (car directives))) - (if (format-directive-p next) - (let ((char (format-directive-character next))) - (if (or (char= kind char) - (and stop-at-semi (char= char #\;))) - (car directives) - (find-directive - (cdr (flet ((after (char) - (member (find-directive (cdr directives) - char - nil) - directives))) - (case char - (#\( (after #\))) - (#\< (after #\>)) - (#\[ (after #\])) - (#\{ (after #\})) - (t directives)))) - kind stop-at-semi))) - (find-directive (cdr directives) kind stop-at-semi))))) - - -;;;; Simple outputting noise. - -(defun format-write-field (stream string mincol colinc minpad padchar padleft) - (unless padleft - (write-string string stream)) - (setf minpad (max minpad 0)) - (dotimes (i minpad) - (write-char padchar stream)) - (and mincol minpad colinc - (do ((chars (+ (length string) minpad) (+ chars colinc))) - ((>= chars mincol)) - (dotimes (i colinc) - (write-char padchar stream)))) - (when padleft - (write-string string stream))) - -(defun format-princ (stream arg colonp atsignp mincol colinc minpad padchar) - (format-write-field stream - (if (or arg (not colonp)) - (princ-to-string arg) - "()") - mincol colinc minpad padchar atsignp)) - -(def-format-directive #\A (colonp atsignp params) - (if params - (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0) - (padchar #\space)) - params - `(format-princ stream ,(expand-next-arg) ',colonp ',atsignp - ,mincol ,colinc ,minpad ,padchar)) - `(princ ,(if colonp - `(or ,(expand-next-arg) "()") - (expand-next-arg)) - stream))) - -(def-format-interpreter #\A (colonp atsignp params) - (if params - (interpret-bind-defaults ((mincol 0) (colinc 1) (minpad 0) - (padchar #\space)) - params - (format-princ stream (next-arg) colonp atsignp - mincol colinc minpad padchar)) - (princ (if colonp (or (next-arg) "()") (next-arg)) stream))) - -(defun format-prin1 (stream arg colonp atsignp mincol colinc minpad padchar) - (format-write-field stream - (if (or arg (not colonp)) - (prin1-to-string arg) - "()") - mincol colinc minpad padchar atsignp)) - -(def-format-directive #\S (colonp atsignp params) - (cond (params - (expand-bind-defaults ((mincol 0) (colinc 1) (minpad 0) - (padchar #\space)) - params - `(format-prin1 stream ,(expand-next-arg) ,colonp ,atsignp - ,mincol ,colinc ,minpad ,padchar))) - (colonp - `(let ((arg ,(expand-next-arg))) - (if arg - (prin1 arg stream) - (princ "()" stream)))) - (t - `(prin1 ,(expand-next-arg) stream)))) - -(def-format-interpreter #\S (colonp atsignp params) - (cond (params - (interpret-bind-defaults ((mincol 0) (colinc 1) (minpad 0) - (padchar #\space)) - params - (format-prin1 stream (next-arg) colonp atsignp - mincol colinc minpad padchar))) - (colonp - (let ((arg (next-arg))) - (if arg - (prin1 arg stream) - (princ "()" stream)))) - (t - (prin1 (next-arg) stream)))) - -(def-format-directive #\C (colonp atsignp params) - (expand-bind-defaults () params - (if colonp - `(format-print-named-character ,(expand-next-arg) stream) - (if atsignp - `(prin1 ,(expand-next-arg) stream) - `(write-char ,(expand-next-arg) stream))))) - -(def-format-interpreter #\C (colonp atsignp params) - (interpret-bind-defaults () params - (if colonp - (format-print-named-character (next-arg) stream) - (if atsignp - (prin1 (next-arg) stream) - (write-char (next-arg) stream))))) - -(defun format-print-named-character (char stream) - (if (printing-char-p char) - (write-char char stream) - (write-string (char-name char) stream))) - -(def-format-directive #\W (colonp atsignp params) - (check-output-layout-mode 1) - (expand-bind-defaults () params - (if (or colonp atsignp) - `(let (,@(when colonp - '((*print-pretty* t))) - ,@(when atsignp - '((*print-level* nil) - (*print-length* nil)))) - (write-object ,(expand-next-arg) stream)) - `(write-object ,(expand-next-arg) stream)))) - -(def-format-interpreter #\W (colonp atsignp params) - (check-output-layout-mode 1) - (interpret-bind-defaults () params - (let ((*print-pretty* (or colonp *print-pretty*)) - (*print-level* (and atsignp *print-level*)) - (*print-length* (and atsignp *print-length*))) - (write-object (next-arg) stream)))) - - -;;;; Integer outputting. - -;;; FORMAT-PRINT-NUMBER does most of the work for the numeric printing -;;; directives. The parameters are interpreted as defined for ~D. -;;; -(defun format-print-integer (stream number print-commas-p print-sign-p - radix mincol padchar commachar commainterval) - (let ((*print-base* radix) - (*print-radix* nil)) - (if (integerp number) - (let* ((text (princ-to-string (abs number))) - (commaed (if print-commas-p - (format-add-commas text commachar commainterval) - text)) - (signed (cond ((minusp number) - (concatenate 'string "-" commaed)) - (print-sign-p - (concatenate 'string "+" commaed)) - (t commaed)))) - ;; colinc = 1, minpad = 0, padleft = t - (format-write-field stream signed mincol 1 0 padchar t)) - (princ number stream)))) - -(defun format-add-commas (string commachar commainterval) - (let ((length (length string))) - (multiple-value-bind (commas extra) - (truncate (1- length) commainterval) - (let ((new-string (make-string (+ length commas))) - (first-comma (1+ extra))) - (replace new-string string :end1 first-comma :end2 first-comma) - (do ((src first-comma (+ src commainterval)) - (dst first-comma (+ dst commainterval 1))) - ((= src length)) - (setf (schar new-string dst) commachar) - (replace new-string string :start1 (1+ dst) - :start2 src :end2 (+ src commainterval))) - new-string)))) - -(defun expand-format-integer (base colonp atsignp params) - (if (or colonp atsignp params) - (expand-bind-defaults - ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3)) - params - `(format-print-integer stream ,(expand-next-arg) ,colonp ,atsignp - ,base ,mincol ,padchar ,commachar - ,commainterval)) - `(write ,(expand-next-arg) :stream stream :base ,base :radix nil - :escape nil))) - -(eval-when (:compile-toplevel :execute) -(defmacro interpret-format-integer (base) - `(if (or colonp atsignp params) - (interpret-bind-defaults - ((mincol 0) (padchar #\space) (commachar #\,) (commainterval 3)) - params - (format-print-integer stream (next-arg) colonp atsignp ,base mincol - padchar commachar commainterval)) - (write (next-arg) :stream stream :base ,base :radix nil :escape nil))) -) - -(def-format-directive #\D (colonp atsignp params) - (expand-format-integer 10 colonp atsignp params)) - -(def-format-interpreter #\D (colonp atsignp params) - (interpret-format-integer 10)) - -(def-format-directive #\B (colonp atsignp params) - (expand-format-integer 2 colonp atsignp params)) - -(def-format-interpreter #\B (colonp atsignp params) - (interpret-format-integer 2)) - -(def-format-directive #\O (colonp atsignp params) - (expand-format-integer 8 colonp atsignp params)) - -(def-format-interpreter #\O (colonp atsignp params) - (interpret-format-integer 8)) - -(def-format-directive #\X (colonp atsignp params) - (expand-format-integer 16 colonp atsignp params)) - -(def-format-interpreter #\X (colonp atsignp params) - (interpret-format-integer 16)) - -(def-format-directive #\R (colonp atsignp params) - (expand-bind-defaults - ((base nil) (mincol 0) (padchar #\space) (commachar #\,) - (commainterval 3)) - params - (let ((n-arg (gensym))) - `(let ((,n-arg ,(expand-next-arg))) - (if ,base - (format-print-integer stream ,n-arg ,colonp ,atsignp - ,base ,mincol - ,padchar ,commachar ,commainterval) - ,(if atsignp - (if colonp - `(format-print-old-roman stream ,n-arg) - `(format-print-roman stream ,n-arg)) - (if colonp - `(format-print-ordinal stream ,n-arg) - `(format-print-cardinal stream ,n-arg)))))))) - -(def-format-interpreter #\R (colonp atsignp params) - (interpret-bind-defaults - ((base nil) (mincol 0) (padchar #\space) (commachar #\,) - (commainterval 3)) - params - (if base - (format-print-integer stream (next-arg) colonp atsignp base mincol - padchar commachar commainterval) - (if atsignp - (if colonp - (format-print-old-roman stream (next-arg)) - (format-print-roman stream (next-arg))) - (if colonp - (format-print-ordinal stream (next-arg)) - (format-print-cardinal stream (next-arg))))))) - -(defconstant-eqx cardinal-ones - #(nil "one" "two" "three" "four" "five" "six" "seven" "eight" "nine") - equalp) - -(defconstant-eqx cardinal-tens - #(nil nil "twenty" "thirty" "forty" - "fifty" "sixty" "seventy" "eighty" "ninety") - equalp) - -(defconstant-eqx cardinal-teens - #("ten" "eleven" "twelve" "thirteen" "fourteen" ;;; RAD - "fifteen" "sixteen" "seventeen" "eighteen" "nineteen") - equalp) - -(defconstant-eqx cardinal-periods - #("" " thousand" " million" " billion" " trillion" " quadrillion" - " quintillion" " sextillion" " septillion" " octillion" " nonillion" - " decillion" " undecillion" " duodecillion" " tredecillion" - " quattuordecillion" " quindecillion" " sexdecillion" " septendecillion" - " octodecillion" " novemdecillion" " vigintillion") - equalp) - -(defconstant-eqx ordinal-ones - #(nil "first" "second" "third" "fourth" - "fifth" "sixth" "seventh" "eighth" "ninth") - equalp - "Table of ordinal ones-place digits in English") - -(defconstant-eqx ordinal-tens - #(nil "tenth" "twentieth" "thirtieth" "fortieth" - "fiftieth" "sixtieth" "seventieth" "eightieth" "ninetieth") - equalp - "Table of ordinal tens-place digits in English") - -(defun format-print-small-cardinal (stream n) - (multiple-value-bind - (hundreds rem) (truncate n 100) - (when (plusp hundreds) - (write-string (svref cardinal-ones hundreds) stream) - (write-string " hundred" stream) - (when (plusp rem) - (write-char #\space stream))) - (when (plusp rem) - (multiple-value-bind (tens ones) - (truncate rem 10) - (cond ((< 1 tens) - (write-string (svref cardinal-tens tens) stream) - (when (plusp ones) - (write-char #\- stream) - (write-string (svref cardinal-ones ones) stream))) - ((= tens 1) - (write-string (svref cardinal-teens ones) stream)) - ((plusp ones) - (write-string (svref cardinal-ones ones) stream))))))) - -(defun format-print-cardinal (stream n) - (cond ((minusp n) - (write-string "negative " stream) - (format-print-cardinal-aux stream (- n) 0 n)) - ((zerop n) - (write-string "zero" stream)) - (t - (format-print-cardinal-aux stream n 0 n)))) - -(defun format-print-cardinal-aux (stream n period err) - (multiple-value-bind (beyond here) (truncate n 1000) - (unless (<= period 20) - (error "Number too large to print in English: ~:D" err)) - (unless (zerop beyond) - (format-print-cardinal-aux stream beyond (1+ period) err)) - (unless (zerop here) - (unless (zerop beyond) - (write-char #\space stream)) - (format-print-small-cardinal stream here) - (write-string (svref cardinal-periods period) stream)))) - -(defun format-print-ordinal (stream n) - (when (minusp n) - (write-string "negative " stream)) - (let ((number (abs n))) - (multiple-value-bind - (top bot) (truncate number 100) - (unless (zerop top) - (format-print-cardinal stream (- number bot))) - (when (and (plusp top) (plusp bot)) - (write-char #\space stream)) - (multiple-value-bind - (tens ones) (truncate bot 10) - (cond ((= bot 12) (write-string "twelfth" stream)) - ((= tens 1) - (write-string (svref cardinal-teens ones) stream);;;RAD - (write-string "th" stream)) - ((and (zerop tens) (plusp ones)) - (write-string (svref ordinal-ones ones) stream)) - ((and (zerop ones)(plusp tens)) - (write-string (svref ordinal-tens tens) stream)) - ((plusp bot) - (write-string (svref cardinal-tens tens) stream) - (write-char #\- stream) - (write-string (svref ordinal-ones ones) stream)) - ((plusp number) - (write-string "th" stream)) - (t - (write-string "zeroth" stream))))))) - -;;; Print Roman numerals - -(defun format-print-old-roman (stream n) - (unless (< 0 n 5000) - (error "Number too large to print in old Roman numerals: ~:D" n)) - (do ((char-list '(#\D #\C #\L #\X #\V #\I) (cdr char-list)) - (val-list '(500 100 50 10 5 1) (cdr val-list)) - (cur-char #\M (car char-list)) - (cur-val 1000 (car val-list)) - (start n (do ((i start (progn - (write-char cur-char stream) - (- i cur-val)))) - ((< i cur-val) i)))) - ((zerop start)))) - -(defun format-print-roman (stream n) - (unless (< 0 n 4000) - (error "Number too large to print in Roman numerals: ~:D" n)) - (do ((char-list '(#\D #\C #\L #\X #\V #\I) (cdr char-list)) - (val-list '(500 100 50 10 5 1) (cdr val-list)) - (sub-chars '(#\C #\X #\X #\I #\I) (cdr sub-chars)) - (sub-val '(100 10 10 1 1 0) (cdr sub-val)) - (cur-char #\M (car char-list)) - (cur-val 1000 (car val-list)) - (cur-sub-char #\C (car sub-chars)) - (cur-sub-val 100 (car sub-val)) - (start n (do ((i start (progn - (write-char cur-char stream) - (- i cur-val)))) - ((< i cur-val) - (cond ((<= (- cur-val cur-sub-val) i) - (write-char cur-sub-char stream) - (write-char cur-char stream) - (- i (- cur-val cur-sub-val))) - (t i)))))) - ((zerop start)))) - - -;;;; Plural. - -(def-format-directive #\P (colonp atsignp params end) - (expand-bind-defaults () params - (let ((arg (cond - ((not colonp) - (expand-next-arg)) - (*orig-args-available* - `(if (eq orig-args args) - (error 'format-error - :complaint "No previous argument." - :offset ,(1- end)) - (do ((arg-ptr orig-args (cdr arg-ptr))) - ((eq (cdr arg-ptr) args) - (car arg-ptr))))) - (*only-simple-args* - (unless *simple-args* - (error 'format-error - :complaint "No previous argument.")) - (caar *simple-args*)) - (t - (throw 'need-orig-args nil))))) - (if atsignp - `(write-string (if (eql ,arg 1) "y" "ies") stream) - `(unless (eql ,arg 1) (write-char #\s stream)))))) - -(def-format-interpreter #\P (colonp atsignp params) - (interpret-bind-defaults () params - (let ((arg (if colonp - (if (eq orig-args args) - (error 'format-error - :complaint "No previous argument.") - (do ((arg-ptr orig-args (cdr arg-ptr))) - ((eq (cdr arg-ptr) args) - (car arg-ptr)))) - (next-arg)))) - (if atsignp - (write-string (if (eql arg 1) "y" "ies") stream) - (unless (eql arg 1) (write-char #\s stream)))))) - - -;;;; Floating point noise. - -(defun decimal-string (n) - (write-to-string n :base 10 :radix nil :escape nil)) - -(def-format-directive #\F (colonp atsignp params) - (when colonp - (error 'format-error - :complaint - "Cannot specify the colon modifier with this directive.")) - (expand-bind-defaults ((w nil) (d nil) (k 0) (ovf nil) (pad #\space)) params - `(format-fixed stream ,(expand-next-arg) ,w ,d ,k ,ovf ,pad ,atsignp))) - -(def-format-interpreter #\F (colonp atsignp params) - (when colonp - (error 'format-error - :complaint - "Cannot specify the colon modifier with this directive.")) - (interpret-bind-defaults ((w nil) (d nil) (k 0) (ovf nil) (pad #\space)) - params - (format-fixed stream (next-arg) w d k ovf pad atsignp))) - -(defun format-fixed (stream number w d k ovf pad atsign) - (if (numberp number) - (if (floatp number) - (format-fixed-aux stream number w d k ovf pad atsign) - (if (rationalp number) - (format-fixed-aux stream - (coerce number 'single-float) - w d k ovf pad atsign) - (format-write-field stream - (decimal-string number) - w 1 0 #\space t))) - (format-princ stream number nil nil w 1 0 pad))) - - -;;; We return true if we overflowed, so that ~G can output the overflow char -;;; instead of spaces. -;;; -(defun format-fixed-aux (stream number w d k ovf pad atsign) - (cond - ((or (not (or w d k)) - (non-finite-float-p number)) - (prin1 number stream) - nil) - (t - (let ((spaceleft w)) - (when (and w (or atsign - (minusp number) - #+ieee-floating-point - (and (zerop number) - (minusp (atan number -1))))) - (decf spaceleft)) - (multiple-value-bind (str len lpoint tpoint) - (sys::flonum-to-string (abs number) spaceleft d k) - ;; if caller specifically requested no fraction digits, suppress the - ;; trailing zero - (when (eql d 0) - (setq tpoint nil)) - (when w - (decf spaceleft len) - ;; obligatory trailing zero (unless explicitly cut with ,d) - (when tpoint - (decf spaceleft)) - ;; optional leading zero - (when lpoint - (if (or (> spaceleft 0) - (eql d 0)) - (decf spaceleft) - (setq lpoint nil)))) - (cond ((and w (< spaceleft 0) ovf) - ;;field width overflow - (dotimes (i w) - (write-char ovf stream)) - t) - (t - (when w (dotimes (i spaceleft) (write-char pad stream))) - (if (or (minusp number) - (and (zerop number) - (minusp (atan number -1)))) - (write-char #\- stream) - (if atsign (write-char #\+ stream))) - (when lpoint (write-char #\0 stream)) - (write-string str stream) - (when tpoint (write-char #\0 stream)) - nil))))))) - -(def-format-directive #\E (colonp atsignp params) - (when colonp - (error 'format-error - :complaint - "Cannot specify the colon modifier with this directive.")) - (expand-bind-defaults - ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (mark nil)) - params - `(format-exponential stream ,(expand-next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark - ,atsignp))) - -(def-format-interpreter #\E (colonp atsignp params) - (when colonp - (error 'format-error - :complaint - "Cannot specify the colon modifier with this directive.")) - (interpret-bind-defaults - ((w nil) (d nil) (e nil) (k 1) (ovf nil) (pad #\space) (mark nil)) - params - (format-exponential stream (next-arg) w d e k ovf pad mark atsignp))) - -(defun format-exponential (stream number w d e k ovf pad marker atsign) - (cond - ((not (numberp number)) - (format-princ stream number nil nil w 1 0 pad)) - ((floatp number) - (format-exp-aux stream number w d e k ovf pad marker atsign)) - ((rationalp number) - (format-exp-aux stream - (coerce number 'single-float) - w d e k ovf pad marker atsign)) - (T - (format-write-field stream - (decimal-string number) - w 1 0 #\space t)))) - -(defun format-exponent-marker (number) - (if (typep number *read-default-float-format*) - #\e - (typecase number - (single-float #\f) - (double-float #\d) - (short-float #\s) - (long-float #\l)))) - -(defun non-finite-float-p (number) - ;; FIXME: Get infinityp and nanp predicates. - ;; numbers.h has them, but only for singles. - #-(or) (declare (ignore number)) - #+(or) - (and (floatp number) - (or (float-infinity-p number) - (float-nan-p number))) - #-(or) nil) - -;;;Here we prevent the scale factor from shifting all significance out of -;;;a number to the right. We allow insignificant zeroes to be shifted in -;;;to the left right, athough it is an error to specify k and d such that this -;;;occurs. Perhaps we should detect both these condtions and flag them as -;;;errors. As for now, we let the user get away with it, and merely guarantee -;;;that at least one significant digit will appear. - -;;; toy@rtp.ericsson.se: The Hyperspec seems to say that the exponent -;;; marker is always printed. Make it so. Also, the original version -;;; causes errors when printing infinities or NaN's. The Hyperspec is -;;; silent here, so let's just print out infinities and NaN's instead -;;; of causing an error. - -(defun format-exp-aux (stream number w d e k ovf pad marker atsign) - (if (non-finite-float-p number) - (prin1 number stream) - (let* ((expt (- (exponent-in-base10 number) k)) - (estr (decimal-string (abs expt))) - (elen (if e (max (length estr) e) (length estr))) - (fdig (if d (if (plusp k) (1+ (- d k)) d) nil)) - (fmin (if (minusp k) (- 1 k) 0)) - (spaceleft (if w - (- w 2 elen - (if (or atsign (minusp number)) - 1 0)) - nil))) - (if (and w ovf e (> elen e)) ;exponent overflow - (dotimes (i w) (write-char ovf stream)) - (multiple-value-bind (fstr flen lpoint tpoint dpos) - (sys::flonum-to-string number spaceleft fdig (- expt) fmin) - (when (and (plusp k) - (< k dpos)) - (incf expt (- dpos k)) - (setf estr (decimal-string (abs expt)) - tpoint nil) - (loop for pos from dpos downto k - do (setf (char fstr pos) (if (= pos k) #\. (char fstr (1- pos)))))) - (when (eql fdig 0) - (setq tpoint nil)) - (when w - (decf spaceleft flen) - (when lpoint - (if (> spaceleft 0) - (decf spaceleft) - (setq lpoint nil))) - (when tpoint - (if (> spaceleft 0) - (decf spaceleft) - (setq tpoint nil)))) - (cond ((and w (< spaceleft 0) ovf) - ;;significand overflow - (dotimes (i w) (write-char ovf stream))) - (t (when w - (dotimes (i spaceleft) (write-char pad stream))) - (if (minusp number) - (write-char #\- stream) - (if atsign (write-char #\+ stream))) - (when lpoint (write-char #\0 stream)) - (write-string fstr stream) - (when tpoint (write-char #\0 stream)) - (write-char (if marker - marker - (format-exponent-marker number)) - stream) - (write-char (if (minusp expt) #\- #\+) stream) - (when e - ;;zero-fill before exponent if necessary - (dotimes (i (- e (length estr))) - (write-char #\0 stream))) - (write-string estr stream)))))))) - -(def-format-directive #\G (colonp atsignp params) - (when colonp - (error 'format-error - :complaint - "Cannot specify the colon modifier with this directive.")) - (expand-bind-defaults - ((w nil) (d nil) (e nil) (k 0) (ovf nil) (pad #\space) (mark nil)) - params - `(format-general stream ,(expand-next-arg) ,w ,d ,e ,k ,ovf ,pad ,mark ,atsignp))) - -(def-format-interpreter #\G (colonp atsignp params) - (when colonp - (error 'format-error - :complaint - "Cannot specify the colon modifier with this directive.")) - (interpret-bind-defaults - ((w nil) (d nil) (e nil) (k 0) (ovf nil) (pad #\space) (mark nil)) - params - (format-general stream (next-arg) w d e k ovf pad mark atsignp))) - -(defun format-general (stream number w d e k ovf pad marker atsign) - (if (numberp number) - (if (floatp number) - (format-general-aux stream number w d e k ovf pad marker atsign) - (if (rationalp number) - (format-general-aux stream - (coerce number 'single-float) - w d e k ovf pad marker atsign) - (format-write-field stream - (decimal-string number) - w 1 0 #\space t))) - (format-princ stream number nil nil w 1 0 pad))) - - -;;; toy@rtp.ericsson.se: Same change as for format-exp-aux. -(defun format-general-aux (stream number w d e k ovf pad marker atsign) - (if (non-finite-float-p number) - (prin1 number stream) - (let ((n (sys::exponent-in-base10 number))) - ;;Default d if omitted. The procedure is taken directly - ;;from the definition given in the manual, and is not - ;;very efficient, since we generate the digits twice. - ;;Future maintainers are encouraged to improve on this. - (unless d - (multiple-value-bind (str len) - (sys::flonum-to-string (abs number)) - (declare (ignore str)) - (let ((q (if (= len 1) 1 (1- len)))) - (setq d (max q (min n 7)))))) - (let* ((ee (if e (+ e 2) 4)) - (ww (if w (- w ee) nil)) - (dd (- d n))) - (cond ((<= 0 dd d) - (let ((char (if (format-fixed-aux stream number ww dd 0 - ovf pad atsign) - ovf - #\space))) - (dotimes (i ee) (write-char char stream)))) - (t - (format-exp-aux stream number w d e (or k 1) - ovf pad marker atsign))))))) - -(def-format-directive #\$ (colonp atsignp params) - (expand-bind-defaults ((d 2) (n 1) (w 0) (pad #\space)) params - `(format-dollars stream ,(expand-next-arg) ,d ,n ,w ,pad ,colonp - ,atsignp))) - -(def-format-interpreter #\$ (colonp atsignp params) - (interpret-bind-defaults ((d 2) (n 1) (w 0) (pad #\space)) params - (format-dollars stream (next-arg) d n w pad colonp atsignp))) - -(defun format-dollars (stream number d n w pad colon atsign) - (if (rationalp number) (setq number (coerce number 'single-float))) - (if (floatp number) - (let* ((signstr (if (minusp number) "-" (if atsign "+" ""))) - (signlen (length signstr))) - (multiple-value-bind (str strlen ig2 ig3 pointplace) - (sys::flonum-to-string (abs number) nil d) - (declare (ignore ig2 ig3)) - (when colon (write-string signstr stream)) - (dotimes (i (- w signlen (max 0 (- n pointplace)) strlen)) - (write-char pad stream)) - (unless colon (write-string signstr stream)) - (dotimes (i (- n pointplace)) (write-char #\0 stream)) - (write-string str stream))) - (format-write-field stream - (decimal-string number) - w 1 0 #\space t))) - - -;;;; line/page breaks and other stuff like that. - -(def-format-directive #\% (colonp atsignp params) - (when (or colonp atsignp) - (error 'format-error - :complaint - "Cannot specify either colon or atsign for this directive.")) - (if params - (expand-bind-defaults ((count 1)) params - `(dotimes (i ,count) - (terpri stream))) - '(terpri stream))) - -(def-format-interpreter #\% (colonp atsignp params) - (when (or colonp atsignp) - (error 'format-error - :complaint - "Cannot specify either colon or atsign for this directive.")) - (interpret-bind-defaults ((count 1)) params - (dotimes (i count) - (terpri stream)))) - -(def-format-directive #\& (colonp atsignp params) - (when (or colonp atsignp) - (error 'format-error - :complaint - "Cannot specify either colon or atsign for this directive.")) - (if params - (expand-bind-defaults ((count 1)) params - `(progn - (fresh-line stream) - (dotimes (i (1- ,count)) - (terpri stream)))) - '(fresh-line stream))) - -(def-format-interpreter #\& (colonp atsignp params) - (when (or colonp atsignp) - (error 'format-error - :complaint - "Cannot specify either colon or atsign for this directive.")) - (interpret-bind-defaults ((count 1)) params - (fresh-line stream) - (dotimes (i (1- count)) - (terpri stream)))) - -(def-format-directive #\| (colonp atsignp params) - (when (or colonp atsignp) - (error 'format-error - :complaint - "Cannot specify either colon or atsign for this directive.")) - (if params - (expand-bind-defaults ((count 1)) params - `(dotimes (i ,count) - (write-char #\page stream))) - '(write-char #\page stream))) - -(def-format-interpreter #\| (colonp atsignp params) - (when (or colonp atsignp) - (error 'format-error - :complaint - "Cannot specify either colon or atsign for this directive.")) - (interpret-bind-defaults ((count 1)) params - (dotimes (i count) - (write-char #\page stream)))) - -(def-format-directive #\~ (colonp atsignp params) - (when (or colonp atsignp) - (error 'format-error - :complaint - "Cannot specify either colon or atsign for this directive.")) - (if params - (expand-bind-defaults ((count 1)) params - `(dotimes (i ,count) - (write-char #\~ stream))) - '(write-char #\~ stream))) - -(def-format-interpreter #\~ (colonp atsignp params) - (when (or colonp atsignp) - (error 'format-error - :complaint - "Cannot specify either colon or atsign for this directive.")) - (interpret-bind-defaults ((count 1)) params - (dotimes (i count) - (write-char #\~ stream)))) - -(def-complex-format-directive #\newline (colonp atsignp params directives) - (when (and colonp atsignp) - (error 'format-error - :complaint - "Cannot specify both colon and atsign for this directive.")) - (values (expand-bind-defaults () params - (if atsignp - '(write-char #\newline stream) - nil)) - (if (and (not colonp) - directives - (simple-string-p (car directives))) - (cons (string-left-trim '(#\space #\newline #\tab) - (car directives)) - (cdr directives)) - directives))) - -(def-complex-format-interpreter #\newline (colonp atsignp params directives) - (when (and colonp atsignp) - (error 'format-error - :complaint - "Cannot specify both colon and atsign for this directive.")) - (interpret-bind-defaults () params - (when atsignp - (write-char #\newline stream))) - (if (and (not colonp) - directives - (simple-string-p (car directives))) - (cons (string-left-trim '(#\space #\newline #\tab) - (car directives)) - (cdr directives)) - directives)) - -(def-complex-format-directive #\return (colonp atsignp params directives) - (when (and colonp atsignp) - (error 'format-error - :complaint - "Cannot specify both colon and atsign for this directive.")) - (values (expand-bind-defaults () params - (if atsignp - '(write-char #\newline stream) - nil)) - (if (and (not colonp) - directives - (simple-string-p (car directives))) - (cons (string-left-trim '(#\space #\newline #\tab) - (car directives)) - (cdr directives)) - directives))) - -(def-complex-format-interpreter #\return (colonp atsignp params directives) - (when (and colonp atsignp) - (error 'format-error - :complaint - "Cannot specify both colon and atsign for this directive.")) - (interpret-bind-defaults () params - (when atsignp - (write-char #\newline stream))) - (if (and (not colonp) - directives - (simple-string-p (car directives))) - (cons (string-left-trim '(#\space #\newline #\tab) - (car directives)) - (cdr directives)) - directives)) - -;;;; * - -(def-format-directive #\* (colonp atsignp params end) - (if atsignp - (if colonp - (error 'format-error - :complaint "Cannot specify both colon and at-sign.") - (expand-bind-defaults ((posn 0)) params - (unless *orig-args-available* - (throw 'need-orig-args nil)) - `(if (<= 0 ,posn (length orig-args)) - (setf args (nthcdr ,posn orig-args)) - (error 'format-error - :complaint "Index ~D out of bounds. Should have been ~ - between 0 and ~D." - :arguments (list ,posn (length orig-args)) - :offset ,(1- end))))) - (if colonp - (expand-bind-defaults ((n 1)) params - (unless *orig-args-available* - (throw 'need-orig-args nil)) - `(do ((cur-posn 0 (1+ cur-posn)) - (arg-ptr orig-args (cdr arg-ptr))) - ((eq arg-ptr args) - (let ((new-posn (- cur-posn ,n))) - (if (<= 0 new-posn (length orig-args)) - (setf args (nthcdr new-posn orig-args)) - (error 'format-error - :complaint - "Index ~D out of bounds. Should have been ~ - between 0 and ~D." - :arguments - (list new-posn (length orig-args)) - :offset ,(1- end))))))) - (if params - (expand-bind-defaults ((n 1)) params - (setf *only-simple-args* nil) - `(dotimes (i ,n) - ,(expand-next-arg))) - (expand-next-arg))))) - -(def-format-interpreter #\* (colonp atsignp params) - (if atsignp - (if colonp - (error 'format-error - :complaint "Cannot specify both colon and at-sign.") - (interpret-bind-defaults ((posn 0)) params - (if (<= 0 posn (length orig-args)) - (setf args (nthcdr posn orig-args)) - (error 'format-error - :complaint "Index ~D out of bounds. Should have been ~ - between 0 and ~D." - :arguments (list posn (length orig-args)))))) - (if colonp - (interpret-bind-defaults ((n 1)) params - (do ((cur-posn 0 (1+ cur-posn)) - (arg-ptr orig-args (cdr arg-ptr))) - ((eq arg-ptr args) - (let ((new-posn (- cur-posn n))) - (if (<= 0 new-posn (length orig-args)) - (setf args (nthcdr new-posn orig-args)) - (error 'format-error - :complaint - "Index ~D out of bounds. Should have been ~ - between 0 and ~D." - :arguments - (list new-posn (length orig-args)))))))) - (interpret-bind-defaults ((n 1)) params - (dotimes (i n) - (next-arg)))))) - - -;;;; Indirection. - -(def-format-directive #\? (colonp atsignp params string end) - (when colonp - (error 'format-error - :complaint "Cannot specify the colon modifier.")) - (expand-bind-defaults () params - `(handler-bind - ((format-error - #'(lambda (condition) - (error 'format-error - :complaint - "~A~%while processing indirect format string:" - :arguments (list condition) - :print-banner nil - :control-string ,string - :offset ,(1- end))))) - ,(if atsignp - (if *orig-args-available* - `(setf args (formatter-aux stream ,(expand-next-arg) orig-args args)) - (throw 'need-orig-args nil)) - `(formatter-aux stream ,(expand-next-arg) ,(expand-next-arg)))))) - -(def-format-interpreter #\? (colonp atsignp params string end) - (when colonp - (error 'format-error - :complaint "Cannot specify the colon modifier.")) - (interpret-bind-defaults () params - (handler-bind - ((format-error - #'(lambda (condition) - (error 'format-error - :complaint - "~A~%while processing indirect format string:" - :arguments (list condition) - :print-banner nil - :control-string string - :offset (1- end))))) - (if atsignp - (setf args (formatter-aux stream (next-arg) orig-args args)) - (formatter-aux stream (next-arg) (next-arg)))))) - - -;;;; Capitalization. - -(defun nstring-capitalize-first (s) - (nstring-downcase s) - (let ((where (position-if #'alpha-char-p s))) - (when where - (nstring-capitalize s :start 0 :end (1+ where))) - s)) - -(def-complex-format-directive #\( (colonp atsignp params directives) - (let ((close (find-directive directives #\) nil))) - (unless close - (error 'format-error - :complaint "No corresponding close paren.")) - (let* ((posn (position close directives)) - (before (subseq directives 0 posn)) - (after (nthcdr (1+ posn) directives))) - (values - (expand-bind-defaults () params - #-(or ecl clasp) - `(let ((stream (make-case-frob-stream stream - ,(if colonp - (if atsignp - :upcase - :capitalize) - (if atsignp - :capitalize-first - :downcase))))) - ,@(expand-directive-list before)) - #+(or ecl clasp) - `(let ((string (make-array 10 :element-type 'character - :fill-pointer 0 :adjustable t))) - (unwind-protect - (with-output-to-string (stream string) - ,@(expand-directive-list before)) - (princ (,(if colonp - (if atsignp 'nstring-upcase 'nstring-capitalize) - (if atsignp 'nstring-capitalize-first 'nstring-downcase)) - string) - stream)))) - after)))) - -(def-complex-format-interpreter #\( (colonp atsignp params directives) - (let ((close (find-directive directives #\) nil))) - (unless close - (error 'format-error - :complaint "No corresponding close paren.")) - (interpret-bind-defaults () params - #-(or ecl clasp) - (let* ((posn (position close directives)) - (before (subseq directives 0 posn)) - (after (nthcdr (1+ posn) directives)) - (stream (make-case-frob-stream stream - (if colonp - (if atsignp - :upcase - :capitalize) - (if atsignp - :capitalize-first - :downcase))))) - (setf args (interpret-directive-list stream before orig-args args)) - after) - #+(or ecl clasp) - (let* ((posn (position close directives)) - (before (subseq directives 0 posn)) - (after (nthcdr (1+ posn) directives)) - (string (make-array 10 :element-type 'character - :adjustable t :fill-pointer 0))) - (unwind-protect - (with-output-to-string (stream string) - (setf args (interpret-directive-list stream before orig-args args))) - (princ (funcall - (if colonp - (if atsignp 'nstring-upcase 'nstring-capitalize) - (if atsignp 'nstring-capitalize-first 'nstring-downcase)) - string) stream)) - after)))) - -(def-complex-format-directive #\) () - (error 'format-error - :complaint "No corresponding open paren.")) - -(def-complex-format-interpreter #\) () - (error 'format-error - :complaint "No corresponding open paren.")) - - -;;;; Conditionals - -(defun parse-conditional-directive (directives) - (let ((sublists nil) - (last-semi-with-colon-p nil) - (remaining directives)) - (loop - (let ((close-or-semi (find-directive remaining #\] t))) - (unless close-or-semi - (error 'format-error - :complaint "No corresponding close bracket.")) - (let ((posn (position close-or-semi remaining))) - (push (subseq remaining 0 posn) sublists) - (setf remaining (nthcdr (1+ posn) remaining)) - (when (char= (format-directive-character close-or-semi) #\]) - (return)) - (setf last-semi-with-colon-p - (format-directive-colonp close-or-semi))))) - (values sublists last-semi-with-colon-p remaining))) - -(def-complex-format-directive #\[ (colonp atsignp params directives) - (multiple-value-bind - (sublists last-semi-with-colon-p remaining) - (parse-conditional-directive directives) - (values - (if atsignp - (if colonp - (error 'format-error - :complaint - "Cannot specify both the colon and at-sign modifiers.") - (if (cdr sublists) - (error 'format-error - :complaint - "Can only specify one section") - (expand-bind-defaults () params - (expand-maybe-conditional (car sublists))))) - (if colonp - (if (= (length sublists) 2) - (expand-bind-defaults () params - (expand-true-false-conditional (car sublists) - (cadr sublists))) - (error 'format-error - :complaint - "Must specify exactly two sections.")) - (expand-bind-defaults ((index nil)) params - (setf *only-simple-args* nil) - (let* ((clauses nil) - (case `(or ,index ,(expand-next-arg)))) - (when last-semi-with-colon-p - (push `(t ,@(expand-directive-list (pop sublists))) - clauses)) - (let ((count (length sublists))) - (dolist (sublist sublists) - (push `(,(decf count) - ,@(expand-directive-list sublist)) - clauses))) - `(case ,case ,@clauses))))) - remaining))) - -(defun expand-maybe-conditional (sublist) - (flet ((hairy () - `(let ((prev-args args) - (arg ,(expand-next-arg))) - (when arg - (setf args prev-args) - ,@(expand-directive-list sublist))))) - (if *only-simple-args* - (multiple-value-bind (guts new-args) - (let ((*simple-args* *simple-args*)) - (values (expand-directive-list sublist) - *simple-args*)) - (cond ((and new-args (eq *simple-args* (cdr new-args))) - (setf *simple-args* new-args) - `(when ,(caar new-args) - ,@guts)) - (t - (setf *only-simple-args* nil) - (hairy)))) - (hairy)))) - -(defun expand-true-false-conditional (true false) - (let ((arg (expand-next-arg))) - (flet ((hairy () - `(if ,arg - (progn - ,@(expand-directive-list true)) - (progn - ,@(expand-directive-list false))))) - (if *only-simple-args* - (multiple-value-bind - (true-guts true-args true-simple) - (let ((*simple-args* *simple-args*) - (*only-simple-args* t)) - (values (expand-directive-list true) - *simple-args* - *only-simple-args*)) - (multiple-value-bind - (false-guts false-args false-simple) - (let ((*simple-args* *simple-args*) - (*only-simple-args* t)) - (values (expand-directive-list false) - *simple-args* - *only-simple-args*)) - (if (= (length true-args) (length false-args)) - `(if ,arg - (progn - ,@true-guts) - ,(do ((false false-args (cdr false)) - (true true-args (cdr true)) - (bindings nil (cons `(,(caar false) ,(caar true)) - bindings))) - ((eq true *simple-args*) - (setf *simple-args* true-args) - (setf *only-simple-args* - (and true-simple false-simple)) - (if bindings - `(let ,bindings - ,@false-guts) - `(progn - ,@false-guts))))) - (progn - (setf *only-simple-args* nil) - (hairy))))) - (hairy))))) - - - -(def-complex-format-interpreter #\[ (colonp atsignp params directives) - (multiple-value-bind - (sublists last-semi-with-colon-p remaining) - (parse-conditional-directive directives) - (setf args - (if atsignp - (if colonp - (error 'format-error - :complaint - "Cannot specify both the colon and at-sign modifiers.") - (if (cdr sublists) - (error 'format-error - :complaint - "Can only specify one section") - (interpret-bind-defaults () params - (let ((prev-args args) - (arg (next-arg))) - (if arg - (interpret-directive-list stream - (car sublists) - orig-args - prev-args) - args))))) - (if colonp - (if (= (length sublists) 2) - (interpret-bind-defaults () params - (if (next-arg) - (interpret-directive-list stream (car sublists) - orig-args args) - (interpret-directive-list stream (cadr sublists) - orig-args args))) - (error 'format-error - :complaint - "Must specify exactly two sections.")) - (interpret-bind-defaults ((index (next-arg))) params - (let* ((default (and last-semi-with-colon-p - (pop sublists))) - (last (1- (length sublists))) - (sublist - (if (<= 0 index last) - (nth (- last index) sublists) - default))) - (interpret-directive-list stream sublist orig-args - args)))))) - remaining)) - -(def-complex-format-directive #\; () - (error 'format-error - :complaint - "~~; not contained within either ~~[...~~] or ~~<...~~>.")) - -(def-complex-format-interpreter #\; () - (error 'format-error - :complaint - "~~; not contained within either ~~[...~~] or ~~<...~~>.")) - -(def-complex-format-interpreter #\] () - (error 'format-error - :complaint - "No corresponding open bracket.")) - -(def-complex-format-directive #\] () - (error 'format-error - :complaint - "No corresponding open bracket.")) - - -;;;; Up-and-out. - -(defvar *outside-args*) - -(def-format-directive #\^ (colonp atsignp params) - (when atsignp - (error 'format-error - :complaint "cannot use the at-sign modifier with this directive")) - (when (and colonp (not *up-up-and-out-allowed*)) - (error 'format-error - :complaint "attempt to use ~~:^ outside a ~~:{...~~} construct")) - `(when ,(expand-bind-defaults ((arg1 nil) (arg2 nil) (arg3 nil)) params - `(cond (,arg3 (<= ,arg1 ,arg2 ,arg3)) - (,arg2 (eql ,arg1 ,arg2)) - (,arg1 (eql ,arg1 0)) - (t ,(if colonp - '(null outside-args) - (progn - (setf *only-simple-args* nil) - '(null args)))))) - ,(if colonp - '(return-from outside-loop nil) - '(return)))) - -(def-format-interpreter #\^ (colonp atsignp params) - (when atsignp - (error 'format-error - :complaint "cannot specify the at-sign modifier")) - (when (and colonp (not *up-up-and-out-allowed*)) - (error 'format-error - :complaint "attempt to use ~~:^ outside a ~~:{...~~} construct")) - (when (interpret-bind-defaults ((arg1 nil) (arg2 nil) (arg3 nil)) params - (cond (arg3 (<= arg1 arg2 arg3)) - (arg2 (eql arg1 arg2)) - (arg1 (eql arg1 0)) - (t (if colonp - (null *outside-args*) - (null args))))) - (throw (if colonp 'up-up-and-out 'up-and-out) - args))) - - -;;;; Iteration. - -(def-complex-format-directive #\{ (colonp atsignp params string end directives) - (let ((close (find-directive directives #\} nil))) - (unless close - (error 'format-error - :complaint "no corresponding close brace")) - (let* ((closed-with-colon (format-directive-colonp close)) - (posn (position close directives))) - (labels - ((compute-insides () - (if (zerop posn) - (if *orig-args-available* - `((handler-bind - ((format-error - (lambda (condition) - (error 'format-error - :complaint - "~A~%while processing indirect format string:" - :args (list condition) - :print-banner nil - :control-string ,string - :offset ,(1- end))))) - (setf args - (formatter-aux stream inside-string orig-args args)))) - (throw 'need-orig-args nil)) - (let ((*up-up-and-out-allowed* colonp)) - (expand-directive-list (subseq directives 0 posn))))) - (compute-loop (count) - (when atsignp - (setf *only-simple-args* nil)) - `(loop - ,@(unless closed-with-colon - '((when (null args) - (return)))) - ,@(when count - `((when (and ,count (minusp (decf ,count))) - (return)))) - ,@(if colonp - (let ((*expander-next-arg-macro* 'expander-next-arg) - (*only-simple-args* nil) - (*orig-args-available* t)) - `((let* ((orig-args ,(expand-next-arg)) - (outside-args args) - (args orig-args)) - (declare (ignorable orig-args outside-args args)) - (block nil - ,@(compute-insides))))) - (compute-insides)) - ,@(when closed-with-colon - '((when (null args) - (return)))))) - (compute-block (count) - (if colonp - `(block outside-loop - ,(compute-loop count)) - (compute-loop count))) - (compute-bindings (count) - (if atsignp - (compute-block count) - `(let* ((orig-args ,(expand-next-arg)) - (args orig-args)) - (declare (ignorable orig-args args)) - ,(let ((*expander-next-arg-macro* 'expander-next-arg) - (*only-simple-args* nil) - (*orig-args-available* t)) - (compute-block count)))))) - (values (if params - (expand-bind-defaults ((count nil)) params - (if (zerop posn) - `(let ((inside-string ,(expand-next-arg))) - ,(compute-bindings count)) - (compute-bindings count))) - (if (zerop posn) - `(let ((inside-string ,(expand-next-arg))) - ,(compute-bindings nil)) - (compute-bindings nil))) - (nthcdr (1+ posn) directives)))))) - -(def-complex-format-interpreter #\{ - (colonp atsignp params string end directives) - (let ((close (find-directive directives #\} nil))) - (unless close - (error 'format-error - :complaint - "No corresponding close brace.")) - (interpret-bind-defaults ((max-count nil)) params - (let* ((closed-with-colon (format-directive-colonp close)) - (posn (position close directives)) - (insides (if (zerop posn) - (next-arg) - (subseq directives 0 posn))) - (*up-up-and-out-allowed* colonp)) - (labels - ((do-guts (orig-args args) - (if (zerop posn) - (handler-bind - ((format-error - #'(lambda (condition) - (error 'format-error - :complaint - "~A~%while processing indirect format string:" - :arguments (list condition) - :print-banner nil - :control-string string - :offset (1- end))))) - (formatter-aux stream insides orig-args args)) - (interpret-directive-list stream insides - orig-args args))) - (bind-args (orig-args args) - (if colonp - (let* ((arg (next-arg)) - (*logical-block-popper* nil) - (*outside-args* args)) - (catch 'up-and-out - (do-guts arg arg)) - args) - (do-guts orig-args args))) - (do-loop (orig-args args) - (catch (if colonp 'up-up-and-out 'up-and-out) - (loop - (when (and (not closed-with-colon) (null args)) - (return)) - (when (and max-count (minusp (decf max-count))) - (return)) - (setf args (bind-args orig-args args)) - (when (and closed-with-colon (null args)) - (return))) - args))) - (if atsignp - (setf args (do-loop orig-args args)) - (let ((arg (next-arg)) - (*logical-block-popper* nil)) - (do-loop arg arg))) - (nthcdr (1+ posn) directives)))))) - -(def-complex-format-directive #\} () - (error 'format-error - :complaint "No corresponding open brace.")) - -(def-complex-format-interpreter #\} () - (error 'format-error - :complaint "No corresponding open brace.")) - -;;;; User-defined method. - -(def-format-directive #\/ (string start end colonp atsignp params) - (let ((symbol (extract-user-function-name string start end))) - (loop for (_ . param) in params - for param-name = (gensym) - collect param-name into param-names - collect `(,param-name - ,(case param - (:arg (expand-next-arg)) - (:remaining '(length args)) - (t param))) - into bindings - finally (return - `(let ,bindings - (,symbol stream ,(expand-next-arg) ,colonp ,atsignp - ,@param-names)))))) - -(def-format-interpreter #\/ (string start end colonp atsignp params) - (let ((symbol (extract-user-function-name string start end)) - (fargs (loop for (_ . param) in params - collect (case param - (:arg (next-arg)) - (:remaining (length args)) - (t param))))) - (apply (fdefinition symbol) stream (next-arg) colonp atsignp fargs))) - -(defun extract-user-function-name (string start end) - (let ((slash (position #\/ string :start start :end (1- end) - :from-end t))) - (unless slash - (error 'format-error - :complaint "Malformed ~~/ directive.")) - (let* ((name (string-upcase (let ((foo string)) - ;; Hack alert: This is to keep the compiler - ;; quit about deleting code inside the subseq - ;; expansion. - (subseq foo (1+ slash) (1- end))))) - (first-colon (position #\: name)) - (second-colon (if first-colon (position #\: name :start (1+ first-colon)))) - (package-name (if first-colon - (subseq name 0 first-colon) - "COMMON-LISP-USER")) - (package (find-package package-name))) - (unless package - (error 'format-error - :complaint "No package named ~S" - :arguments (list package-name))) - (intern (cond - ((and second-colon (= second-colon (1+ first-colon))) - (subseq name (1+ second-colon))) - (first-colon - (subseq name (1+ first-colon))) - (t name)) - package)))) - -;;; Originally contributed by stassats May 24, 2016 -(let () ; FIXME: Use during build -(define-compiler-macro format (&whole whole destination control-string &rest args - &environment env) - ;; Be especially nice about the common programmer error of - ;; (format "control-string" ...) - (when (and (constantp destination env) - (stringp (ext:constant-form-value destination env))) - (ext:with-current-source-form (destination) - (warn "Literal string as destination in FORMAT:~% ~s" whole)) - (return-from format whole)) - (let ((original-control-string control-string) - (control-string (and (constantp control-string env) - (ext:constant-form-value control-string env)))) - (if (stringp control-string) - (let ((dest-sym (gensym "DEST")) - (stream-sym (gensym "STREAM"))) - (multiple-value-bind (guts variables) - ;; We call %formatter-guts here because it has the side effect - ;; of signaling an error if the control string is invalid. - ;; We want to do that before check-min/max-format-arguments. - (ext:with-current-source-form (original-control-string) - (%formatter-guts control-string)) - (check-min/max-format-arguments control-string (length args)) - (let* ((body - (if (eq variables 't) - `(,(%formatter-lambda control-string guts variables) - ,stream-sym ,@args) - (gen-inline-format - control-string guts variables stream-sym args))) - (dest-constantp (constantp destination env)) - (dest (and dest-constantp - (ext:constant-form-value destination env)))) - ;; If the destination is constant T or NIL, avoid bothering with it - ;; at runtime. - ;; NOTE: With constant propagation this would be unnecessary. - (cond ((and dest-constantp (eq dest nil)) - `(with-output-to-string (,stream-sym) ,body)) - ((eq dest 't) ; must be constant - `(let ((,stream-sym *standard-output*)) ,body)) - (t - ;; no dice - runtime dispatch - ;; NOTE: If the body exits abnormally, which it can because of - ;; ~// or just argument evaluations, the string stream is not - ;; closed. However unlike normal with-output-to-string, nothing - ;; can refer to it, so hopefully it'll just be GC'd normally. - `(let* ((,dest-sym ,destination) - (,stream-sym - (cond ((null ,dest-sym) - (make-string-output-stream)) - ((eq ,dest-sym t) *standard-output*) - ((stringp ,dest-sym) - (core:make-string-output-stream-from-string - ,dest-sym)) - (t ,dest-sym)))) - ,body - (if (null ,dest-sym) - (get-output-stream-string ,stream-sym) - nil))))))) - whole)))) - -;;; Given a formatter form that doesn't do anything fancy with arguments, -;;; expand into some code to execute it with the given args. -;;; NOTE: If we could inline functions with &optional &rest, this would be -;;; redundant. At the moment we can't. -(defun gen-inline-format (control-string guts variables streamvar args) - (if (> (length variables) (length args)) - ;; not enough args is special cased. - ;; note check-min/max-format-arguments already issued a warning. - (let* ((nargs (length args)) - (first-unsupplied-offset (cdr (nth nargs variables))) - (varsyms (mapcar #'car variables)) - (bound-vars (subseq varsyms 0 nargs))) - `(let (,@(mapcar #'list bound-vars args) - (stream ,streamvar)) - (declare (ignore ,@bound-vars stream)) - ,(simple-formatter-param-err-form control-string - first-unsupplied-offset))) - ;; Normal case - (let* ((varsyms (mapcar #'car variables))) - `(let (,@(mapcar #'list varsyms args) - ;; It's important that we bind these fixed variables - ;; only AFTER evaluating the format arguments. - ;; Otherwise, something like (format nil ... core::stream) - ;; will be problematic. - (stream ,streamvar) - ;; Remaining arguments are collected in a list. - ;; They can be used by e.g. ~@{ - (args (list ,@(nthcdr (length variables) args)))) - (declare (ignorable args)) - ,guts)))) - -;;;; Compile-time checking of format arguments and control string - -;;; Conditions the FORMAT compiler macro signals if there's an argument count mismatch. -;;; CLHS 22.3.10.2 says that having too few arguments is undefined, so that's a warning, -;;; but having too many just means they're ignored, so that's a style-warning. -;;; (Alternately we could not complain at all.) -(define-condition format-warning-too-few-arguments (warning) - ((control-string :initarg :control :reader format-warning-control-string) - (expected :initarg :expected :reader format-warning-expected) - (observed :initarg :observed :reader format-warning-observed)) - (:report (lambda (condition stream) - (format stream - "Format string ~s expects at least ~d arguments,~@ - but is only provided ~d." - (format-warning-control-string condition) - (format-warning-expected condition) - (format-warning-observed condition))))) -(define-condition format-warning-too-many-arguments (style-warning) - ((control-string :initarg :control :reader format-warning-control-string) - (expected :initarg :expected :reader format-warning-expected) - (observed :initarg :observed :reader format-warning-observed)) - (:report (lambda (condition stream) - (format stream - "Format string ~s expects at most ~d arguments,~@ - but is provided ~d." - (format-warning-control-string condition) - (format-warning-expected condition) - (format-warning-observed condition))))) - -;;; -;;; Signal a warning if the given control string will not work with -;;; the given number of arguments. Assumes the control string's validity. -;;; -(defun check-min/max-format-arguments (control-string nargs) - (multiple-value-bind (min max) - (catch 'give-up - (%min/max-format-args (tokenize-control-string control-string))) - (cond ((and min (< nargs min)) - (warn 'format-warning-too-few-arguments - :control control-string - :expected min - :observed nargs)) - ((and max (> nargs max)) - (warn 'format-warning-too-many-arguments - :control control-string - :expected min :observed nargs))))) - -(defun %min/max-format-args (directives) - (let ((min-req 0) (max-req 0)) - (flet ((incf-both (&optional (n 1)) - (incf min-req n) - (incf max-req n))) - (loop - (let ((dir (pop directives))) - (when (null dir) - (return (values min-req max-req))) - (when (format-directive-p dir) - (incf-both (count :arg (format-directive-params dir) :key #'cdr)) - (let ((c (format-directive-character dir))) - (cond ((find c "ABCDEFGORSWX$/") - (incf-both)) - ((char= c #\P) - (unless (format-directive-colonp dir) - (incf-both))) - ((or (find c "IT%&|_<>();") (char= c #\newline))) - ((char= c #\[) - (multiple-value-bind (min max remaining) - (%min/max-conditional-args dir directives) - (setq directives remaining) - (incf min-req min) - (incf max-req max))) - ((char= c #\{) - (multiple-value-bind (min max remaining) - (%min/max-iteration-args dir directives) - (setq directives remaining) - (incf min-req min) - (incf max-req max))) - ((char= c #\?) - (cond ((format-directive-atsignp dir) - (incf min-req) - (setq max-req most-positive-fixnum)) - (t (incf-both 2)))) - (t (throw 'give-up nil)))))))))) - -;;; -;;; ANSI: if arg is out of range, no clause is selected. That means -;;; the minimum number of args required for the interior of ~[~] is -;;; always zero. -;;; -(defun %min/max-conditional-args (conditional directives) - (multiple-value-bind (sublists last-semi-with-colon-p remaining) - (parse-conditional-directive directives) - (declare (ignore last-semi-with-colon-p)) - (let ((sub-max (loop for s in sublists maximize - (nth-value 1 (%min/max-format-args s)))) - (min-req 1) - max-req) - (cond ((format-directive-atsignp conditional) - (setq max-req (max 1 sub-max))) - ((loop for p in (format-directive-params conditional) - thereis (or (integerp (cdr p)) - (member (cdr p) '(:remaining :arg) :test #'eq))) - (setq min-req 0) - (setq max-req sub-max)) - (t - (setq max-req (1+ sub-max)))) - (values min-req max-req remaining)))) - -(defun %min/max-iteration-args (iteration directives) - (let* ((close (find-directive directives #\} nil)) - (posn (position close directives)) - (remaining (nthcdr (1+ posn) directives))) - (if (format-directive-atsignp iteration) - (values (if (zerop posn) 1 0) most-positive-fixnum remaining) - (let ((nreq (if (zerop posn) 2 1))) - (values nreq nreq remaining))))) - -(eval-when (:load-toplevel :execute) - ;; Swap in the cl:format command - (setf (fdefinition 'cl:format) #'sys::format-std)) diff --git a/src/lisp/kernel/lsp/iolib.lisp b/src/lisp/kernel/lsp/iolib.lisp index 01ac59baa9..50dc0207b2 100644 --- a/src/lisp/kernel/lsp/iolib.lisp +++ b/src/lisp/kernel/lsp/iolib.lisp @@ -77,99 +77,6 @@ object's representation." (values (read stream eof-error-p eof-value) (file-position stream))))) -;;; This function does what write-to-string does to a symbol name, -;;; when printer escaping is off. -;;; It's over five times as far as write-to-string. -(defun printcasify (symbol-name readtable-case print-case) - (let ((result (copy-seq symbol-name)) - (len (length symbol-name))) - (case readtable-case - ((:preserve) result) - ((:invert) - (dotimes (i len result) - (let ((c (aref result i))) - (setf (aref result i) - (cond ((upper-case-p c) - (char-downcase c)) - ((lower-case-p c) - (char-upcase c)) - (t c)))))) - ((:upcase) - (let ((capitalize t)) - (dotimes (i len result) - (let ((c (aref result i))) - (setf (aref result i) - (if (and (upper-case-p c) - (or (eq print-case :downcase) - (and (eq print-case :capitalize) - (not capitalize)))) - (char-downcase c) - c) - capitalize (not (alphanumericp c))))))) - ((:downcase) - (let ((capitalize t)) - (dotimes (i len result) - (let ((c (aref result i))) - (setf (aref result i) - (if (and (lower-case-p c) - (or (eq print-case :downcase) - (and (eq print-case :capitalize) - capitalize))) - (char-downcase c) - c) - capitalize (not (alphanumericp c)))))))))) - -(defun stringify (object) - (when (and (not *print-escape*) (not *print-readably*) (not *print-pretty*)) - (cond - ((symbolp object) - (return-from stringify - (printcasify (symbol-name object) - (readtable-case *readtable*) - *print-case*))) - ((stringp object) (return-from stringify (copy-seq object))) - ((characterp object) (return-from stringify (string object))))) - ;; By not making a fresh stream every time, we save some time. - (let ((stream (core:thread-local-write-to-string-output-stream))) - (write-object object stream) - (core:get-thread-local-write-to-string-output-stream-string stream))) - -(defun write-to-string (object &key ((:escape *print-escape*) *print-escape*) - ((:radix *print-radix*) *print-radix*) - ((:base *print-base*) *print-base*) - ((:circle *print-circle*) *print-circle*) - ((:pretty *print-pretty*) *print-pretty*) - ((:level *print-level*) *print-level*) - ((:length *print-length*) *print-length*) - ((:case *print-case*) *print-case*) - ((:array *print-array*) *print-array*) - ((:gensym *print-gensym*) *print-gensym*) - ((:readably *print-readably*) *print-readably*) - ((:right-margin *print-right-margin*) - *print-right-margin*) - ((:miser-width *print-miser-width*) - *print-miser-width*) - ((:lines *print-lines*) *print-lines*) - ((:pprint-dispatch *print-pprint-dispatch*) - *print-pprint-dispatch*)) - "Returns as a string the printed representation of OBJECT in the specified -mode. See the variable docs of *PRINT-...* for the mode." - (stringify object)) - -(defun prin1-to-string (object) - "Args: (object) -PRIN1s OBJECT to a new string and returns the result. Equivalent to - (WRITE-TO-STRING OBJECT :ESCAPE T)." - (let ((*print-escape* t)) - (stringify object))) - -(defun princ-to-string (object) - "Args: (object) -PRINCs OBJECT to a new string and returns the result. Equivalent to - (WRITE-TO-STRING OBJECT :ESCAPE NIL :READABLY NIL)." - (let ((*print-escape* nil) (*print-readably* nil)) - (stringify object))) - (defmacro with-open-file ((stream . filespec) &rest body) "Syntax: (with-open-file (var filespec-form {options}*) {decl}* {form}*) Opens the specified file using OPTIONs, and evaluates FORMs with VAR bound to @@ -183,28 +90,30 @@ OPEN for the options." (MULTIPLE-VALUE-PROG1 (PROGN ,@b) (WHEN ,stream (CLOSE ,stream))) (WHEN ,stream (CLOSE ,stream :ABORT T)))))) -(defun y-or-n-p (&optional string &rest args) - "Args: (&optional format-string &rest args) +(defun y-or-n-p (&optional control &rest args) + "Args: (&optional format-control &rest args) Asks the user a Y-or-N question. Does FRESH-LINE, prints a message as if -FORMAT-STRING and ARGs were given to FORMAT, and then prints \"(Y or N)\" is -printed. If FORMAT-STRING is NIL, however, no prompt will appear." +CONTROL and ARGs were given to FORMAT, and then prints \"(Y or N)\" is +printed. If CONTROL is NIL, however, no prompt will appear." (do ((reply)) (nil) - (when string (format *query-io* "~&~? (Y or N) " string args)) + (when control + (format *query-io* "~&~? (Y or N) " control args)) (setq reply (read *query-io*)) (cond ((string-equal (symbol-name reply) "Y") (return-from y-or-n-p t)) ((string-equal (symbol-name reply) "N") (return-from y-or-n-p nil))))) -(defun yes-or-no-p (&optional string &rest args) - "Args: (&optional format-string &rest args) +(defun yes-or-no-p (&optional control &rest args) + "Args: (&optional format-control &rest args) Asks the user an YES-or-NO question. Does FRESH-LINE, prints a message as if -FORMAT-STRING and ARGs were given to FORMAT, and then prints \"(Y or N)\" is -printed. If FORMAT-STRING is NIL, however, no prompt will appear." +CONTROL and ARGs were given to FORMAT, and then prints \"(Y or N)\" is +printed. If CONTROL is NIL, however, no prompt will appear." (do ((reply)) (nil) - (when string (format *query-io* "~&~? (Yes or No) " string args)) + (when control + (format *query-io* "~&~? (Yes or No) " control args)) (setq reply (read *query-io*)) (cond ((string-equal (symbol-name reply) "YES") (return-from yes-or-no-p t)) @@ -291,98 +200,55 @@ is not given, ends the recording." ;(provide 'iolib) -(eval-when (:compile-toplevel :load-toplevel :execute) -(defvar +io-syntax-progv-list+ - (list - '( - *print-pprint-dispatch* #| See end of pprint.lisp |# - *print-array* - *print-base* - *print-case* - *print-circle* - *print-escape* - *print-gensym* - *print-length* - *print-level* - *print-lines* - *print-miser-width* - *print-pretty* - *print-radix* - *print-readably* - *print-right-margin* - *read-base* - *read-default-float-format* - *read-eval* - *read-suppress* - *readtable* - *package* - si::*sharp-eq-context* - si::*circle-counter*) ; - nil ;; *pprint-dispatch-table* - t ;; *print-array* - 10 ;; *print-base* - :upcase ;; *print-case* - nil ;; *print-circle* - t ;; *print-escape* - t ;; *print-gensym* - nil ;; *print-length* - nil ;; *print-level* - nil ;; *print-lines* - nil ;; *print-miser-width* - nil ;; *print-pretty* - nil ;; *print-radix* - t ;; *print-readably* - nil ;; *print-right-margin* - 10 ;; *read-base* - 'single-float ;; *read-default-float-format* - t ;; *read-eval* - nil ;; *read-suppress* - *readtable* ;; *readtable* - (find-package :CL-USER) ;; *package* - nil ;; si::*sharp-eq-context* - nil ;; si::*circle-counter* - )) -) ; eval-when - (defmacro with-standard-io-syntax (&body body) "Syntax: ({forms}*) The forms of the body are executed in a print environment that corresponds to the one defined in the ANSI standard. *print-base* is 10, *print-array* is t, *package* is \"CL-USER\", etc." - (with-clean-symbols (%progv-list) - `(let ((%progv-list +io-syntax-progv-list+)) - (progv (car %progv-list) - (cdr %progv-list) - ,@body)))) - -(defun print-unreadable-object-contents (object stream type identity body) - (when type - (write (type-of object) :stream stream :circle nil - :level nil :length nil) - (write-char #\space stream)) - (when body - (funcall body)) - (when identity - (when (or body (not type)) - (write-char #\space stream)) - (write-char #\@ stream) - (core:write-addr object stream))) - -;;; The guts of print-unreadable-object, inspired by SBCL. -;;; pprint-logical-block isn't available yet, so this function -;;; will be redefined later in pprint.lisp once the pretty -;;; printer is available. -(defun %print-unreadable-object (object stream type identity body) - (cond (*print-readably* - (error 'print-not-readable :object object)) - (t - (let ((stream (cond ((null stream) - *standard-output*) - ((eq t stream) - *terminal-io*) - (t - stream)))) - (write-string "#<" stream) - (print-unreadable-object-contents object stream type identity body) - (write-char #\> stream)))) - nil) + `(progv '(*print-pprint-dispatch* + *print-array* + *print-base* + *print-case* + *print-circle* + *print-escape* + *print-gensym* + *print-length* + *print-level* + *print-lines* + *print-miser-width* + *print-pretty* + *print-radix* + *print-readably* + *print-right-margin* + *read-base* + *read-default-float-format* + *read-eval* + *read-suppress* + *readtable* + *package* + si::*sharp-eq-context* + si::*circle-counter*) + (list inravina-intrinsic::*standard-pprint-dispatch* ;; *pprint-dispatch-table* + t ;; *print-array* + 10 ;; *print-base* + :upcase ;; *print-case* + nil ;; *print-circle* + t ;; *print-escape* + t ;; *print-gensym* + nil ;; *print-length* + nil ;; *print-level* + nil ;; *print-lines* + nil ;; *print-miser-width* + nil ;; *print-pretty* + nil ;; *print-radix* + t ;; *print-readably* + nil ;; *print-right-margin* + 10 ;; *read-base* + 'single-float ;; *read-default-float-format* + t ;; *read-eval* + nil ;; *read-suppress* + (symbol-value 'core::+standard-readtable+) ;; *readtable* + (find-package :CL-USER) ;; *package* + nil ;; si::*sharp-eq-context* + nil) ;; si::*circle-counter* + ,@body)) diff --git a/src/lisp/kernel/lsp/late-printer.lisp b/src/lisp/kernel/lsp/late-printer.lisp new file mode 100644 index 0000000000..cada9d97cb --- /dev/null +++ b/src/lisp/kernel/lsp/late-printer.lisp @@ -0,0 +1,39 @@ +(in-package #:sys) + +(defun %write-object (object stream) + (incless:write-object incless-intrinsic:*client* object stream)) + +(defun %circle-check (object) + (incless:circle-check incless-intrinsic:*client* object nil)) + +(defmethod print-object (object stream) + (write-ugly-object object stream)) + +(defmethod incless:printing-char-p ((client incless-intrinsic:client) char) + (printing-char-p char)) + +(define-compiler-macro assert-failure (&whole form &rest args) + (declare (ignore args)) + (invistra:expand-function incless-intrinsic:*client* form 4)) + +(define-compiler-macro simple-program-error (&whole form &rest args) + (declare (ignore args)) + (invistra:expand-function incless-intrinsic:*client* form 1)) + +(define-compiler-macro simple-reader-error (&whole form &rest args) + (declare (ignore args)) + (invistra:expand-function incless-intrinsic:*client* form 2)) + +(define-compiler-macro signal-simple-error (&whole form &rest args) + (declare (ignore args)) + (invistra:expand-function incless-intrinsic:*client* form 2 3)) + +(in-package #:mp) + +(define-compiler-macro interrupt (&whole form &rest args) + (declare (ignore args)) + (invistra:expand-function incless-intrinsic:*client* form 3)) + +(define-compiler-macro raise (&whole form &rest args) + (declare (ignore args)) + (invistra:expand-function incless-intrinsic:*client* form 2)) diff --git a/src/lisp/kernel/lsp/module.lisp b/src/lisp/kernel/lsp/module.lisp index 24820e5dd1..b0493a24aa 100644 --- a/src/lisp/kernel/lsp/module.lisp +++ b/src/lisp/kernel/lsp/module.lisp @@ -64,9 +64,6 @@ Module-name is a string designator" (defparameter *requiring* nil) -(defun require-error (control &rest arguments) - (error "Module error: ~?" control arguments)) - (defun require (module-name &optional pathnames) "Loads a module, unless it already has been loaded. PATHNAMES, if supplied, is a designator for a list of pathnames to be loaded if the module @@ -77,8 +74,8 @@ responsible for calling PROVIDE to indicate a successful load of the module." (let ((name (normalize-module-name module-name))) (when (member name *requiring* :test #'string=) - (require-error "~@" 'require module-name)) + (error "Module error: ~@" 'require module-name)) (let ((saved-modules (copy-list *modules*)) (*requiring* (cons name *requiring*))) (unless (member name *modules* :test #'string=) @@ -91,8 +88,8 @@ module." (t (unless (some (lambda (p) (funcall p module-name)) ext:*module-provider-functions*) - (require-error "Don't know how to ~S ~A." - 'require module-name))))) + (error "Module error: Don't know how to ~S ~A." + 'require module-name))))) (set-difference *modules* saved-modules)))) (defparameter *fasl-extensions* (list "NFASL" "FASL")) diff --git a/src/lisp/kernel/lsp/numlib.lisp b/src/lisp/kernel/lsp/numlib.lisp index ab56da9bc1..9ab55423b2 100644 --- a/src/lisp/kernel/lsp/numlib.lisp +++ b/src/lisp/kernel/lsp/numlib.lisp @@ -369,3 +369,13 @@ specified bits of INTEGER2 with the specified bits of INTEGER1." (if size `(%deposit-field ,newbyte ,size ,position ,integer) whole)))) + +(defun %the-single (type value) + (unless (typep value type) + (error 'type-error :datum value :expected-type type)) + value) + +(defun %the-single-return (type value return) + (unless (typep value type) + (error 'type-error :datum value :expected-type type)) + return) diff --git a/src/lisp/kernel/lsp/pprint.lisp b/src/lisp/kernel/lsp/pprint.lisp deleted file mode 100644 index 0cb8b76f94..0000000000 --- a/src/lisp/kernel/lsp/pprint.lisp +++ /dev/null @@ -1,1261 +0,0 @@ -;;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: SYSTEM -*- -;;;; -;;; -*- Package: PRETTY-PRINT -*- -;;; -;;; ********************************************************************** -;;; This code was written as part of the CMU Common Lisp project at -;;; Carnegie Mellon University, and has been placed in the public domain. -;;; -;;; CMU Common Lisp pretty printer. -;;; Written by William Lott. Algorithm stolen from Richard Waters' XP. -;;; - -(in-package "SI") - -(defconstant +ecl-safe-declarations+ - (if (boundp '+ecl-safe-declarations+) - (symbol-value '+ecl-safe-declarations+) - '(optimize (safety 2) (speed 1) (debug 1) (space 1)))) - -;;; FIXME: Move? -;;; FIXME: Better error (though these are internal structures, so it being signaled is a bug) -(defun required-argument () - (error "Missing required argument in struct constructor")) - -;;; since (ext:check-arguments-type) is a no-op in clasp -;;; just used to check member types -(defmacro %verify-type (datum type) - (let ((datum-symbol (gensym))) - `(let ((,datum-symbol ,datum)) - (unless (typep ,datum-symbol ,type) - (error 'type-error :datum ,datum-symbol :expected-type ,type))))) -;;;; Pretty streams - -;;; There are three different units for measuring character positions: -;;; COLUMN - offset (if characters) from the start of the current line. -;;; INDEX - index into the output buffer. -;;; POSN - some position in the stream of characters cycling through -;;; the output buffer. -;;; -(deftype column () - '(and fixnum unsigned-byte)) -;;; The INDEX type is picked up from the kernel package. -(deftype posn () - 'fixnum) - -(defconstant initial-buffer-size 128) - -(defconstant default-line-length 80) - -(defclass pretty-stream (gray:fundamental-character-output-stream) ( - ;; - ;; Where the output is going to finally go. - ;; - (target :initarg :target :initform t :type stream - :accessor pretty-stream-target) - ;; - ;; Line length we should format to. Cached here so we don't have to keep - ;; extracting it from the target stream. - (line-length :initarg :line-length - :type column - :accessor pretty-stream-line-length) - ;; - ;; A simple string holding all the text that has been output but not yet - ;; printed. - (buffer :initform (make-string initial-buffer-size) :type simple-string - :accessor pretty-stream-buffer) - ;; - ;; The index into BUFFER where more text should be put. - (buffer-fill-pointer :initform 0 :type index :accessor pretty-stream-buffer-fill-pointer) - ;; - ;; Whenever we output stuff from the buffer, we shift the remaining noise - ;; over. This makes it difficult to keep references to locations in - ;; the buffer. Therefore, we have to keep track of the total amount of - ;; stuff that has been shifted out of the buffer. - (buffer-offset :initform 0 :type posn :accessor pretty-stream-buffer-offset) - ;; - ;; The column the first character in the buffer will appear in. Normally - ;; zero, but if we end up with a very long line with no breaks in it we - ;; might have to output part of it. Then this will no longer be zero. - (buffer-start-column :initarg :buffer-start-column :type column - :accessor pretty-stream-buffer-start-column) - ;; - ;; The line number we are currently on. Used for *print-lines* abrevs and - ;; to tell when sections have been split across multiple lines. - (line-number :initform 0 :type index - :accessor pretty-stream-line-number) - ;; - ;; Stack of logical blocks in effect at the buffer start. - (blocks :initform (list (make-logical-block)) :type list - :accessor pretty-stream-blocks) - ;; - ;; Buffer holding the per-line prefix active at the buffer start. - ;; Indentation is included in this. The length of this is stored - ;; in the logical block stack. - (prefix :initform (make-string initial-buffer-size) :type string - :accessor pretty-stream-prefix) - ;; - ;; Buffer holding the total remaining suffix active at the buffer start. - ;; The characters are right-justified in the buffer to make it easier - ;; to output the buffer. The length is stored in the logical block - ;; stack. - (suffix :initform (make-string initial-buffer-size) :type string - :accessor pretty-stream-suffix) - ;; - ;; Queue of pending operations. When empty, HEAD=TAIL=NIL. Otherwise, - ;; TAIL holds the first (oldest) cons and HEAD holds the last (newest) - ;; cons. Adding things to the queue is basically (setf (cdr head) (list - ;; new)) and removing them is basically (pop tail) [except that care must - ;; be taken to handle the empty queue case correctly.] - (queue-tail :initform nil :type list :accessor pretty-stream-queue-tail) - (queue-head :initform nil :type list :accessor pretty-stream-queue-head) - ;; - ;; Block-start queue entries in effect at the queue head. - (pending-blocks :initform nil :type list :accessor pretty-stream-pending-blocks) - ) -) - -(defun pretty-stream-p (stream) - (typep stream 'pretty-stream)) - -(defun target-stream (stream) - (if (pretty-stream-p stream) - (pretty-stream-target stream) - stream)) - -(defun make-pretty-stream (target) - (make-instance 'pretty-stream - :target target - :buffer-start-column (or (stream-output-column target) 0) - :line-length (or *print-right-margin* - (gray:stream-line-length target) - default-line-length))) - -(defmethod print-object ((pretty-stream pretty-stream) stream) - (print-unreadable-object (pretty-stream stream :type t :identity t)) - #+nil - (format stream "#" - (kernel:get-lisp-obj-address pretty-stream))) - -(declaim (inline index-posn posn-index posn-column)) -(defun index-posn (index stream) - (declare (type index index) (type pretty-stream stream)) - (+ index (pretty-stream-buffer-offset stream))) -(defun posn-index (posn stream) - (declare (type posn posn) (type pretty-stream stream)) - (- posn (pretty-stream-buffer-offset stream))) -(defun posn-column (posn stream) - (declare (type posn posn) (type pretty-stream stream)) - (index-column (posn-index posn stream) stream)) - - -;;;; Stream interface routines. - -(defmethod gray:stream-line-length ((stream pretty-stream)) - (pretty-stream-line-length stream)) - -(defmethod gray::stream-write-char ((stream pretty-stream) char) - (pretty-out stream char)) - -(defmethod gray::stream-force-output ((stream pretty-stream)) - (declare (ignore stream)) - ;(force-pretty-output stream) -) - -(defmethod gray::stream-clear-output ((stream pretty-stream)) - (declare (type pretty-stream stream)) - (clear-output (pretty-stream-target stream))) - -(defun pretty-out (stream char) - (declare (type pretty-stream stream) - (type character char)) - (cond ((char= char #\newline) - (enqueue-newline stream :literal)) - (t - (assure-space-in-buffer stream 1) - (let ((fill-pointer (pretty-stream-buffer-fill-pointer stream))) - (setf (schar (pretty-stream-buffer stream) fill-pointer) char) - (setf (pretty-stream-buffer-fill-pointer stream) - (1+ fill-pointer)))))) - -(defun pretty-sout (stream string start end) - (declare (type pretty-stream stream) - (type string string) - (type index start) - (type (or index null) end)) - (let ((end (or end (length string)))) - (unless (= start end) - (let ((newline (position #\newline string :start start :end end))) - (cond - (newline - (pretty-sout stream string start newline) - (enqueue-newline stream :literal) - (pretty-sout stream string (1+ newline) end)) - (t - (let ((chars (- end start))) - (loop - (let* ((available (assure-space-in-buffer stream chars)) - (count (min available chars)) - (fill-pointer (pretty-stream-buffer-fill-pointer stream)) - (new-fill-ptr (+ fill-pointer count))) - (replace (pretty-stream-buffer stream) - string - :start1 fill-pointer :end1 new-fill-ptr - :start2 start) - (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr) - (decf chars count) - (when (zerop count) - (return)) - (incf start count)))))))))) - - -;;;; Logical blocks. - -(defstruct logical-block - ;; - ;; The column this logical block started in. - (start-column 0 :type column) - ;; - ;; The column the current section started in. - (section-column 0 :type column) - ;; - ;; The length of the per-line prefix. We can't move the indentation - ;; left of this. - (per-line-prefix-end 0 :type index) - ;; - ;; The overall length of the prefix, including any indentation. - (prefix-length 0 :type index) - ;; - ;; The overall length of the suffix. - (suffix-length 0 :type index) - ;; - ;; The line number - (section-start-line 0 :type index)) - -(defun really-start-logical-block (stream column prefix suffix) - (declare (type pretty-stream stream)) - (let* ((blocks (pretty-stream-blocks stream)) - (prev-block (car blocks)) - (per-line-end (logical-block-per-line-prefix-end prev-block)) - (prefix-length (logical-block-prefix-length prev-block)) - (suffix-length (logical-block-suffix-length prev-block)) - (block (make-logical-block - :start-column column - :section-column column - :per-line-prefix-end per-line-end - :prefix-length prefix-length - :suffix-length suffix-length - :section-start-line (pretty-stream-line-number stream)))) - (setf (pretty-stream-blocks stream) (cons block blocks)) - (set-indentation stream column) - (when prefix - (setf (logical-block-per-line-prefix-end block) column) - (replace (pretty-stream-prefix stream) prefix - :start1 (- column (length prefix)) :end1 column)) - (when suffix - (let* ((total-suffix (pretty-stream-suffix stream)) - (total-suffix-len (length total-suffix)) - (additional (length suffix)) - (new-suffix-len (+ suffix-length additional))) - (when (> new-suffix-len total-suffix-len) - (let ((new-total-suffix-len - (max (* total-suffix-len 2) - (+ suffix-length - (floor (* additional 5) 4))))) - (setf total-suffix - (replace (make-string new-total-suffix-len) total-suffix - :start1 (- new-total-suffix-len suffix-length) - :start2 (- total-suffix-len suffix-length))) - (setf total-suffix-len new-total-suffix-len) - (setf (pretty-stream-suffix stream) total-suffix))) - (replace total-suffix suffix - :start1 (- total-suffix-len new-suffix-len) - :end1 (- total-suffix-len suffix-length)) - (setf (logical-block-suffix-length block) new-suffix-len)))) - nil) - -(defun set-indentation (stream column) - (declare (type pretty-stream stream)) - (let* ((prefix (pretty-stream-prefix stream)) - (prefix-len (length prefix)) - (block (car (pretty-stream-blocks stream))) - (current (logical-block-prefix-length block)) - (minimum (logical-block-per-line-prefix-end block)) - (column (max minimum column))) - (when (> column prefix-len) - (setf prefix - (replace (make-string (max (* prefix-len 2) - (+ prefix-len - (floor (* (- column prefix-len) 5) - 4)))) - prefix - :end1 current)) - (setf (pretty-stream-prefix stream) prefix)) - (when (> column current) - (fill prefix #\space :start current :end column)) - (setf (logical-block-prefix-length block) column))) - -(defun really-end-logical-block (stream) - (declare (type pretty-stream stream)) - (let* ((old (pop (pretty-stream-blocks stream))) - (old-indent (logical-block-prefix-length old)) - (new (car (pretty-stream-blocks stream))) - (new-indent (logical-block-prefix-length new))) - (when (> new-indent old-indent) - (fill (pretty-stream-prefix stream) #\space - :start old-indent :end new-indent))) - nil) - - -;;;; The pending operation queue. - -(defstruct queued-op - (posn 0 :type posn)) - -(eval-when (:compile-toplevel :execute) -(defmacro enqueue (stream type &rest args) - (let ((constructor (intern (concatenate 'string - "MAKE-" - (symbol-name type))))) - (once-only ((stream stream) - (entry `(,constructor :posn - (index-posn - (pretty-stream-buffer-fill-pointer - ,stream) - ,stream) - ,@args)) - (op `(list ,entry)) - (head `(pretty-stream-queue-head ,stream))) - `(progn - (if ,head - (setf (cdr ,head) ,op) - (setf (pretty-stream-queue-tail ,stream) ,op)) - (setf (pretty-stream-queue-head ,stream) ,op) - ,entry)))) -) - -(defstruct (section-start - (:include queued-op)) - (depth 0 :type index) - (section-end nil :type (or null newline block-end))) - -(defstruct (newline - (:include section-start)) - (kind (required-argument) - :type (member :linear :fill :miser :literal :mandatory))) - -(defun enqueue-newline (stream kind) - (declare (type pretty-stream stream)) - (let* ((depth (length (pretty-stream-pending-blocks stream))) - (newline (enqueue stream newline :kind kind :depth depth))) - (dolist (entry (pretty-stream-queue-tail stream)) - (when (and (not (eq newline entry)) - (section-start-p entry) - (null (section-start-section-end entry)) - (<= depth (section-start-depth entry))) - (setf (section-start-section-end entry) newline)))) - (maybe-output stream (or (eq kind :literal) (eq kind :mandatory)))) - -(defstruct (indentation - (:include queued-op)) - (kind (required-argument) :type (member :block :current)) - (amount 0 :type fixnum)) - -(defun enqueue-indent (stream kind amount) - (declare (type pretty-stream stream)) - (enqueue stream indentation :kind kind :amount amount)) - -(defstruct (block-start - (:include section-start)) - (block-end nil :type (or null block-end)) - (prefix nil :type (or null string)) - (suffix nil :type (or null string))) - -(defun start-logical-block (stream prefix per-line-p suffix) - (declare (type string prefix suffix) - (type pretty-stream stream) - (ext:check-arguments-type)) - (let ((prefix-len (length prefix))) - (when (plusp prefix-len) - (pretty-sout stream prefix 0 prefix-len)) - (let* ((pending-blocks (pretty-stream-pending-blocks stream)) - (start (enqueue stream block-start - :prefix (and (plusp prefix-len) per-line-p prefix) - :suffix (and (plusp (length suffix)) suffix) - :depth (length pending-blocks)))) - (setf (pretty-stream-pending-blocks stream) - (cons start pending-blocks))))) - -(defstruct (block-end - (:include queued-op)) - (suffix nil :type (or null string))) - -(defun end-logical-block (stream) - (declare (type pretty-stream stream)) - (let* ((start (pop (pretty-stream-pending-blocks stream))) - (suffix (block-start-suffix start)) - (end (enqueue stream block-end :suffix suffix))) - (when suffix - (pretty-sout stream suffix 0 (length suffix))) - (setf (block-start-block-end start) end))) - -(defstruct (tab - (:include queued-op)) - (sectionp nil :type (member t nil)) - (relativep nil :type (member t nil)) - (colnum 0 :type column) - (colinc 0 :type column)) - -(defun enqueue-tab (stream kind colnum colinc) - (declare (type pretty-stream stream)) - (multiple-value-bind - (sectionp relativep) - (ecase kind - (:line (values nil nil)) - (:line-relative (values nil t)) - (:section (values t nil)) - (:section-relative (values t t))) - (enqueue stream tab :sectionp sectionp :relativep relativep - :colnum colnum :colinc colinc))) - - -;;;; Tab support. - -(defun compute-tab-size (tab section-start column) - (let ((colnum (tab-colnum tab)) - (colinc (tab-colinc tab))) - (when (tab-sectionp tab) - (setf column (- column section-start))) - (cond ((tab-relativep tab) - (unless (<= colinc 1) - (let ((newposn (+ column colnum))) - (let ((rem (rem newposn colinc))) - (unless (zerop rem) - (incf colnum (- colinc rem)))))) - colnum) - ((< column colnum) - (- colnum column)) - ((= column colnum) - colinc) - ((plusp colinc) - (- colinc (rem (- column colnum) colinc))) - (t - 0)))) - -(defun index-column (index stream) - (declare (type pretty-stream stream)) - (let ((column (pretty-stream-buffer-start-column stream)) - (section-start (logical-block-section-column - (first (pretty-stream-blocks stream)))) - (end-posn (index-posn index stream))) - (dolist (op (pretty-stream-queue-tail stream)) - (when (>= (queued-op-posn op) end-posn) - (return)) - (typecase op - (tab - (incf column - (compute-tab-size op - section-start - (+ column - (posn-index (tab-posn op) - stream))))) - ((or newline block-start) - (setf section-start - (+ column (posn-index (queued-op-posn op) - stream)))))) - (+ column index))) - -(defun expand-tabs (stream through) - (declare (type pretty-stream stream)) - (let ((insertions nil) - (additional 0) - (column (pretty-stream-buffer-start-column stream)) - (section-start (logical-block-section-column - (first (pretty-stream-blocks stream))))) - (dolist (op (pretty-stream-queue-tail stream)) - (typecase op - (tab - (let* ((index (posn-index (tab-posn op) stream)) - (tabsize (compute-tab-size op - section-start - (+ column index)))) - (unless (zerop tabsize) - (push (cons index tabsize) insertions) - (incf additional tabsize) - (incf column tabsize)))) - ((or newline block-start) - (setf section-start - (+ column (posn-index (queued-op-posn op) stream))))) - (when (eq op through) - (return))) - (when insertions - (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream)) - (new-fill-ptr (+ fill-ptr additional)) - (buffer (pretty-stream-buffer stream)) - (new-buffer buffer) - (length (length buffer)) - (end fill-ptr)) - (when (> new-fill-ptr length) - (let ((new-length (max (* length 2) - (+ fill-ptr - (floor (* additional 5) 4))))) - (setf new-buffer (make-string new-length)) - (setf (pretty-stream-buffer stream) new-buffer))) - (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr) - (decf (pretty-stream-buffer-offset stream) additional) - (dolist (insertion insertions) - (let* ((srcpos (car insertion)) - (amount (cdr insertion)) - (dstpos (+ srcpos additional))) - (replace new-buffer buffer :start1 dstpos :start2 srcpos :end2 end) - (fill new-buffer #\space :start (- dstpos amount) :end dstpos) - (decf additional amount) - (setf end srcpos))) - (unless (eq new-buffer buffer) - (replace new-buffer buffer :end1 end :end2 end)))))) - - -;;;; Stuff to do the actual outputting. - -(defun assure-space-in-buffer (stream want) - (declare (type pretty-stream stream) - (type index want)) - (let* ((buffer (pretty-stream-buffer stream)) - (length (length buffer)) - (fill-ptr (pretty-stream-buffer-fill-pointer stream)) - (available (- length fill-ptr))) - (cond ((plusp available) - available) - ((> fill-ptr (pretty-stream-line-length stream)) - (unless (maybe-output stream nil) - (output-partial-line stream)) - (assure-space-in-buffer stream want)) - (t - (let* ((new-length (max (* length 2) - (+ length - (floor (* want 5) 4)))) - (new-buffer (make-string new-length))) - (setf (pretty-stream-buffer stream) new-buffer) - (replace new-buffer buffer :end1 fill-ptr) - (- new-length fill-ptr)))))) - -(defun maybe-output (stream force-newlines-p) - (declare (type pretty-stream stream)) - (let ((tail (pretty-stream-queue-tail stream)) - (output-anything nil)) - (loop - (unless tail - (setf (pretty-stream-queue-head stream) nil) - (return)) - (let ((next (pop tail))) - (etypecase next - (newline - (when (ecase (newline-kind next) - ((:literal :mandatory :linear) t) - (:miser (misering-p stream)) - (:fill - (or (misering-p stream) - (> (pretty-stream-line-number stream) - (logical-block-section-start-line - (first (pretty-stream-blocks stream)))) - (ecase (fits-on-line-p stream - (newline-section-end next) - force-newlines-p) - ((t) nil) - ((nil) t) - (:dont-know - (return)))))) - (setf output-anything t) - (output-line stream next))) - (indentation - (unless (misering-p stream) - (set-indentation stream - (+ (ecase (indentation-kind next) - (:block - (logical-block-start-column - (car (pretty-stream-blocks stream)))) - (:current - (posn-column - (indentation-posn next) - stream))) - (indentation-amount next))))) - (block-start - (ecase (fits-on-line-p stream (block-start-section-end next) - force-newlines-p) - ((t) - ;; Just nuke the whole logical block and make it look like one - ;; nice long literal. - (let ((end (block-start-block-end next))) - (expand-tabs stream end) - (setf tail (cdr (member end tail))))) - ((nil) - (really-start-logical-block - stream - (posn-column (block-start-posn next) stream) - (block-start-prefix next) - (block-start-suffix next))) - (:dont-know - (return)))) - (block-end - (really-end-logical-block stream)) - (tab - (expand-tabs stream next)))) - (setf (pretty-stream-queue-tail stream) tail)) - output-anything)) - -(defun misering-p (stream) - (declare (type pretty-stream stream)) - (and *print-miser-width* - (<= (- (pretty-stream-line-length stream) - (logical-block-start-column (car (pretty-stream-blocks stream)))) - *print-miser-width*))) - -(defun fits-on-line-p (stream until force-newlines-p) - (declare (type pretty-stream stream)) - (let ((available (pretty-stream-line-length stream))) - (when (and (not *print-readably*) *print-lines* - (= *print-lines* (pretty-stream-line-number stream))) - (decf available 3) ; for the `` ..'' - (decf available (logical-block-suffix-length - (car (pretty-stream-blocks stream))))) - (cond (until - (<= (posn-column (queued-op-posn until) stream) available)) - (force-newlines-p nil) - ((> (index-column (pretty-stream-buffer-fill-pointer stream) stream) - available) - nil) - (t - :dont-know)))) - -(defun output-line (stream until) - (declare (type pretty-stream stream) - (type newline until)) - (let* ((target (pretty-stream-target stream)) - (buffer (pretty-stream-buffer stream)) - (kind (newline-kind until)) - (literal-p (eq kind :literal)) - (amount-to-consume (posn-index (newline-posn until) stream)) - (amount-to-print - (if literal-p - amount-to-consume - (let ((last-non-blank - (position #\space buffer :end amount-to-consume - :from-end t :test #'char/=))) - (if last-non-blank - (1+ last-non-blank) - 0))))) - (write-string buffer target :end amount-to-print) - (let ((line-number (pretty-stream-line-number stream))) - (incf line-number) - (when (and (not *print-readably*) - *print-lines* (>= line-number *print-lines*)) - (write-string " .." target) - (let ((suffix-length (logical-block-suffix-length - (car (pretty-stream-blocks stream))))) - (unless (zerop suffix-length) - (let* ((suffix (pretty-stream-suffix stream)) - (len (length suffix))) - (write-string suffix target - :start (- len suffix-length) - :end len)))) - (throw 'line-limit-abbreviation-happened t)) - (setf (pretty-stream-line-number stream) line-number) - (write-char #\newline target) - (setf (pretty-stream-buffer-start-column stream) 0) - (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream)) - (block (first (pretty-stream-blocks stream))) - (prefix-len - (if literal-p - (logical-block-per-line-prefix-end block) - (logical-block-prefix-length block))) - (shift (- amount-to-consume prefix-len)) - (new-fill-ptr (- fill-ptr shift)) - (new-buffer buffer) - (buffer-length (length buffer))) - (when (> new-fill-ptr buffer-length) - (setf new-buffer - (make-string (max (* buffer-length 2) - (+ buffer-length - (floor (* (- new-fill-ptr buffer-length) - 5) - 4))))) - (setf (pretty-stream-buffer stream) new-buffer)) - (replace new-buffer buffer - :start1 prefix-len :start2 amount-to-consume :end2 fill-ptr) - (replace new-buffer (pretty-stream-prefix stream) - :end1 prefix-len) - (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr) - (incf (pretty-stream-buffer-offset stream) shift) - (unless literal-p - (setf (logical-block-section-column block) prefix-len) - (setf (logical-block-section-start-line block) line-number)))))) - -(defun output-partial-line (stream) - (declare (type pretty-stream stream)) - (let* ((fill-ptr (pretty-stream-buffer-fill-pointer stream)) - (tail (pretty-stream-queue-tail stream)) - (count - (if tail - (posn-index (queued-op-posn (car tail)) stream) - fill-ptr)) - (new-fill-ptr (- fill-ptr count)) - (buffer (pretty-stream-buffer stream))) - (when (zerop count) - (error "Output-partial-line called when nothing can be output.")) - (write-string buffer (pretty-stream-target stream) - :start 0 :end count) - (incf (pretty-stream-buffer-start-column stream) count) - (replace buffer buffer :end1 new-fill-ptr :start2 count :end2 fill-ptr) - (setf (pretty-stream-buffer-fill-pointer stream) new-fill-ptr) - (incf (pretty-stream-buffer-offset stream) count))) - -(defun force-pretty-output (stream) - (declare (type pretty-stream stream)) - (maybe-output stream nil) - (expand-tabs stream nil) - (write-string (pretty-stream-buffer stream) - (pretty-stream-target stream) - :end (pretty-stream-buffer-fill-pointer stream))) - - -;;;; Utilities. - -(defun pprint-pop-helper (object count stream &aux code) - (cond ((or (not (listp object)) - (and (plusp count) - (consp (cdr object)) - (null (cddr object)) - (or (eq (car object) 'core:quasiquote) - (and (getf core:*quasiquote* (target-stream stream)) - (member (car object) - '(core:unquote core:unquote-splice core:unquote-nsplice)))))) - (write-string ". " stream) - (write-object object stream) - nil) - ((and (not *print-readably*) - (eql count *print-length*)) - (write-string "..." stream) - nil) - ((or (null object) - (zerop count) - (null *circle-counter*)) - t) - ((eql 'NULL (setf code (gethash object *circle-stack* 'NULL))) - ;; We visit this part of the list for the first time and thus we must - ;; register it in the hash, or we are on the second pass and have - ;; found a completely new list. This should not happend, but anyway - ;; we try to print it. - (search-print-circle object) - t) - ((and (null code) (integerp *circle-counter*)) - ;; This object is not visited twice. - t) - (t - ;; In all other cases, WRITE-OBJECT - (write-string ". " stream) - (write-object object stream) - nil))) - -;;;; User interface to the pretty printer. - -(defun check-print-level () - "Automatically handle *print-level* abbreviation. If we are too deep, then - a # is printed to STREAM and BODY is ignored." - (cond ((or *print-readably* (null *print-level*)) - t) - ((zerop *print-level*) - nil) - (t - (setf *print-level* (1- *print-level*))))) - -(defun search-print-circle (object) - (multiple-value-bind - (code present-p) - (gethash object *circle-stack*) - (if (not (fixnump *circle-counter*)) - (cond ((not present-p) - ;; Was not found before - (setf (gethash object *circle-stack*) nil) - 0) - ((null code) - ;; Second reference - (setf (gethash object *circle-stack*) t) - 1) - (t - ;; Further references - 2)) - (cond ((or (not present-p) (null code)) - ;; Is not referenced or was not found before - 0) - ((eql code t) - ;; Reference twice but had no code yet - (incf *circle-counter*) - (setf (gethash object *circle-stack*) - *circle-counter*) - (- *circle-counter*)) - (t code))))) - -(defun write-object-with-circle (object stream function) - (if (and *print-circle* - (not (null object)) - (not (fixnump object)) - (not (characterp object)) - (or (not (symbolp object)) (null (symbol-package object)))) - ;;; *print-circle* and an object that might have a circle - (if (null *circle-counter*) - (let* ((hash (make-hash-table :test 'eq - :size 1024)) - (*circle-counter* t) - (*circle-stack* hash)) - (write-object-with-circle object (make-broadcast-stream) function) - (setf *circle-counter* 0) - (write-object-with-circle object stream function) - (clrhash hash) - object) - (let ((code (search-print-circle object))) - (cond ((not (fixnump *circle-counter*)) - ;; We are only inspecting the object to be printed. - ;; Only print X if it was not referenced before - (if (not (zerop code)) - object - (funcall function object stream))) - ((zerop code) - ;; Object is not referenced twice - (funcall function object stream)) - ((minusp code) - ;; Object is referenced twice. We print its definition - (write-char #\# stream) - (let ((*print-radix* nil) - (*print-base* 10)) - (write-ugly-object (- code) stream)) - (write-char #\= stream) - (funcall function object stream)) - (t - ;; Second reference to the object - (write-char #\# stream) - (let ((*print-radix* nil) - (*print-base* 10)) - (write-ugly-object code stream)) - (write-char #\# stream) - object)) - )) - ;;; live is good, print simple - (funcall function object stream) - )) - -(defun do-pprint-logical-block (function object stream prefix - per-line-prefix-p suffix) - (cond ((not (listp object)) - (write-object object stream)) - ((and (not *print-readably*) (eql *print-level* 0)) - (write-char #\# stream)) - (t (write-object-with-circle - object stream - #'(lambda (object stream1) - (unless (pretty-stream-p stream1) - (setf stream1 (make-pretty-stream stream1))) - (let ((*print-level* (and (not *print-readably*) - *print-level* - (1- *print-level*)))) - (start-logical-block stream1 prefix per-line-prefix-p suffix) - (funcall function object stream1) - (end-logical-block stream1)))))) - nil) - -(defun pprint-logical-block-helper (function object stream prefix - per-line-prefix-p suffix) - (check-type prefix string) - (check-type suffix string) - (setf stream (case stream - ((nil) *standard-output*) - ((t) *terminal-io*) - (t stream))) - (if (pretty-stream-p stream) - (do-pprint-logical-block function object stream prefix - per-line-prefix-p suffix) - (let ((stream (make-pretty-stream stream))) - (catch 'line-limit-abbreviation-happened - (do-pprint-logical-block function object stream prefix - per-line-prefix-p suffix) - (force-pretty-output stream)) - nil))) - -(defmacro pprint-logical-block - ((stream-symbol object &key (prefix "" prefix-p) - (per-line-prefix "" per-line-prefix-p) - (suffix "")) - &body body) - "Group some output into a logical block. STREAM-SYMBOL should be either a - stream, T (for *TERMINAL-IO*), or NIL (for *STANDARD-OUTPUT*). The printer - control variable *PRINT-LEVEL* is automatically handled." - (declare #.+ecl-safe-declarations+) - (when per-line-prefix-p - (when prefix-p - (error "Cannot specify both a prefix and a per-line-prefix.")) - (setf prefix per-line-prefix)) - (let* ((object-var (gensym)) - (block-name (gensym "PPRINT-LOGICAL-BLOCK-")) - (count-name (gensym "PPRINT-LOGICAL-BLOCK-LENGTH-")) - (stream-var (case stream-symbol - ((nil) '*standard-output*) - ((t) '*terminal-io*) - (t stream-symbol))) - (function - `(lambda (,object-var ,stream-var &aux (,count-name 0)) - (declare (ignorable ,object-var ,stream-var ,count-name) - (core:lambda-name ,block-name)) - (block ,block-name - (macrolet ((pprint-pop () - '(progn - (unless (pprint-pop-helper ,object-var ,count-name - ,stream-var) - (return-from ,block-name nil)) - (incf ,count-name) - ,(if object `(pop ,object-var) nil))) - (pprint-exit-if-list-exhausted () - ,(if object - `'(when (null ,object-var) - (return-from ,block-name nil)) - `'(return-from ,block-name nil)))) - ,@body))))) - `(pprint-logical-block-helper #',function ,object ,stream-symbol - ,prefix ,per-line-prefix-p ,suffix))) - -(defmacro pprint-exit-if-list-exhausted () - "Cause the closest enclosing use of PPRINT-LOGICAL-BLOCK to return - if it's list argument is exhausted. Can only be used inside - PPRINT-LOGICAL-BLOCK, and only when the LIST argument to - PPRINT-LOGICAL-BLOCK is supplied." - (declare #.+ecl-safe-declarations+) - (error "PPRINT-EXIT-IF-LIST-EXHAUSTED must be lexically inside ~ - PPRINT-LOGICAL-BLOCK.")) - -(defmacro pprint-pop () - "Return the next element from LIST argument to the closest enclosing - use of PPRINT-LOGICAL-BLOCK, automatically handling *PRINT-LENGTH* - and *PRINT-CIRCLE*. Can only be used inside PPRINT-LOGICAL-BLOCK. - If the LIST argument to PPRINT-LOGICAL-BLOCK was NIL, then nothing - is poped, but the *PRINT-LENGTH* testing still happens." - (declare #.+ecl-safe-declarations+) - (error "PPRINT-POP must be lexically inside PPRINT-LOGICAL-BLOCK.")) - -(defun pprint-newline (kind &optional stream) - "Output a conditional newline to STREAM (which defaults to - *STANDARD-OUTPUT*) if it is a pretty-printing stream, and do - nothing if not. KIND can be one of: - :LINEAR - A line break is inserted if and only if the immediatly - containing section cannot be printed on one line. - :MISER - Same as LINEAR, but only if ``miser-style'' is in effect. - (See *PRINT-MISER-WIDTH*.) - :FILL - A line break is inserted if and only if either: - (a) the following section cannot be printed on the end of the - current line, - (b) the preceding section was not printed on a single line, or - (c) the immediately containing section cannot be printed on one - line and miser-style is in effect. - :MANDATORY - A line break is always inserted. - When a line break is inserted by any type of conditional newline, any - blanks that immediately precede the conditional newline are ommitted - from the output and indentation is introduced at the beginning of the - next line. (See PPRINT-INDENT.)" - (declare (type (member :linear :miser :fill :mandatory) kind) - (type (or stream (member t nil)) stream) - (ext:check-arguments-type)) - (%verify-type kind '(member :linear :miser :fill :mandatory)) - (let ((stream (case stream - ((t) *terminal-io*) - ((nil) *standard-output*) - (t stream)))) - (when (and (pretty-stream-p stream) *print-pretty*) - (enqueue-newline stream kind))) - nil) - -(defun pprint-indent (relative-to n &optional stream) - "Specify the indentation to use in the current logical block if STREAM - (which defaults to *STANDARD-OUTPUT*) is it is a pretty-printing stream - and do nothing if not. (See PPRINT-LOGICAL-BLOCK.) N is the indention - to use (in ems, the width of an ``m'') and RELATIVE-TO can be either: - :BLOCK - Indent relative to the column the current logical block - started on. - :CURRENT - Indent relative to the current column. - The new indention value does not take effect until the following line - break." - (declare (type (member :block :current) relative-to) - (type real n) - (type (or stream (member t nil)) stream) - (ext:check-arguments-type)) - (%verify-type relative-to '(member :block :current)) - (let ((stream (case stream - ((t) *terminal-io*) - ((nil) *standard-output*) - (t stream)))) - (when (and (pretty-stream-p stream) *print-pretty*) - (enqueue-indent stream relative-to (round n)))) - nil) - -(defun pprint-tab (kind colnum colinc &optional stream) - "If STREAM (which defaults to *STANDARD-OUTPUT*) is a pretty-printing - stream, perform tabbing based on KIND, otherwise do nothing. KIND can - be one of: - :LINE - Tab to column COLNUM. If already past COLNUM tab to the next - multiple of COLINC. - :SECTION - Same as :LINE, but count from the start of the current - section, not the start of the line. - :LINE-RELATIVE - Output COLNUM spaces, then tab to the next multiple of - COLINC. - :SECTION-RELATIVE - Same as :LINE-RELATIVE, but count from the start - of the current section, not the start of the line." - (declare (type (member :line :section :line-relative :section-relative) kind) - (type unsigned-byte colnum colinc) - (type (or stream (member t nil)) stream) - (ext:check-arguments-type)) - (%verify-type kind '(member :line :section :line-relative :section-relative)) - (let ((stream (case stream - ((t) *terminal-io*) - ((nil) *standard-output*) - (t stream)))) - (when (and (pretty-stream-p stream) *print-pretty*) - (enqueue-tab stream kind colnum colinc))) - nil) - -(defun pprint-fill (stream list &optional (colon? t) atsign?) - "Output LIST to STREAM putting :FILL conditional newlines between each - element. If COLON? is NIL (defaults to T), then no parens are printed - around the output. ATSIGN? is ignored (but allowed so that PPRINT-FILL - can be used with the ~/.../ format directive." - (declare (ignore atsign?) - (type (or stream (member t nil)) stream) - (ext:check-arguments-type) - #.+ecl-safe-declarations+) - (pprint-logical-block (stream list - :prefix (if colon? "(" "") - :suffix (if colon? ")" "")) - (pprint-exit-if-list-exhausted) - (loop - (write-object (pprint-pop) stream) - (pprint-exit-if-list-exhausted) - (write-char #\space stream) - (pprint-newline :fill stream)))) - -(defun pprint-linear (stream list &optional (colon? t) atsign?) - "Output LIST to STREAM putting :LINEAR conditional newlines between each - element. If COLON? is NIL (defaults to T), then no parens are printed - around the output. ATSIGN? is ignored (but allowed so that PPRINT-LINEAR - can be used with the ~/.../ format directive." - (declare (ignore atsign?) - (type (or stream (member t nil)) stream) - (ext:check-arguments-type) - #.+ecl-safe-declarations+) - (pprint-logical-block (stream list - :prefix (if colon? "(" "") - :suffix (if colon? ")" "")) - (pprint-exit-if-list-exhausted) - (loop - (write-object (pprint-pop) stream) - (pprint-exit-if-list-exhausted) - (write-char #\space stream) - (pprint-newline :linear stream)))) - -(defun pprint-tabular (stream list &optional (colon? t) atsign? (tabsize 16)) - "Output LIST to STREAM tabbing to the next column that is an even multiple - of TABSIZE (which defaults to 16) between each element. :FILL style - conditional newlines are also output between each element. If COLON? is - NIL (defaults to T), then no parens are printed around the output. - ATSIGN? is ignored (but allowed so that PPRINT-TABULAR can be used with - the ~/.../ format directive." - (declare (ignore atsign?) - (type (or stream (member t nil)) stream) - (type (or unsigned-byte null) tabsize) - (ext:check-arguments-type)) - (pprint-logical-block (stream list - :prefix (if colon? "(" "") - :suffix (if colon? ")" "")) - (pprint-exit-if-list-exhausted) - (loop - (write-object (pprint-pop) stream) - (pprint-exit-if-list-exhausted) - (write-char #\space stream) - (pprint-tab :section-relative 0 (or tabsize 16) stream) - (pprint-newline :fill stream)))) - - -;;;; Pprint-dispatch tables. - -(defvar *standard-pprint-dispatch*) -(defvar *initial-pprint-dispatch*) - -(defstruct (pprint-dispatch-entry - (:print-function %print-pprint-dispatch-entry)) - ;; - ;; The type specifier for this entry. - (type (required-argument) :type t) - ;; - ;; The priority for this guy. - (priority 0 :type real) - ;; - ;; T iff one of the original entries. - (initial-p (not (boundp '*initial-pprint-dispatch*)) :type (member t nil)) - ;; - ;; And the associated function. - (function (required-argument) :type (or function symbol))) - -(defun %print-pprint-dispatch-entry (entry stream depth) - (declare (ignore depth)) - (print-unreadable-object (entry stream :type t) - (format stream "Type=~S, priority=~S~@[ [Initial]~]" - (pprint-dispatch-entry-type entry) - (pprint-dispatch-entry-priority entry) - (pprint-dispatch-entry-initial-p entry)))) - -(defstruct (pprint-dispatch-table - (:print-function %print-pprint-dispatch-table)) - ;; Are we allowed to modify this table? - (read-only-p nil) - ;; - ;; A list of all the entries (except for CONS entries below) in highest - ;; to lowest priority. - (entries nil :type list) - ;; - ;; A hash table mapping things to entries for type specifiers of the - ;; form (CONS (MEMBER )). If the type specifier is of this form, - ;; we put it in this hash table instead of the regular entries table. - (cons-entries (make-hash-table :test #'eql))) - -(defun %print-pprint-dispatch-table (table stream depth) - (declare (ignore depth)) - (print-unreadable-object (table stream :type t :identity t))) - -(defun cons-type-specifier-p (spec) - (and (consp spec) - (eq (car spec) 'cons) - (cdr spec) - (null (cddr spec)) - (let ((car (cadr spec))) - (and (consp car) - (let ((carcar (car car))) - (or (eq carcar 'member) - (eq carcar 'eql))) - (cdr car) - (null (cddr car)))))) - -(defun entry< (e1 e2) - (declare (type pprint-dispatch-entry e1 e2)) - (if (pprint-dispatch-entry-initial-p e1) - (if (pprint-dispatch-entry-initial-p e2) - (< (pprint-dispatch-entry-priority e1) - (pprint-dispatch-entry-priority e2)) - t) - (if (pprint-dispatch-entry-initial-p e2) - nil - (< (pprint-dispatch-entry-priority e1) - (pprint-dispatch-entry-priority e2))))) - - -(defun copy-pprint-dispatch (&optional (table *print-pprint-dispatch*)) - (declare #.+ecl-safe-declarations+) - (unless (typep table '(or null pprint-dispatch-table)) - (error 'type-error :datum table - :expected-type '(or null pprint-dispatch-table))) - (let* ((orig (or table *initial-pprint-dispatch*)) - (new (make-pprint-dispatch-table - :entries (copy-list (pprint-dispatch-table-entries orig)))) - (new-cons-entries (pprint-dispatch-table-cons-entries new))) - (maphash #'(lambda (key value) - (setf (gethash key new-cons-entries) value)) - (pprint-dispatch-table-cons-entries orig)) - new)) - -(defun default-pprint-dispatch (stream object) - (write-ugly-object object stream)) - -(defun pprint-dispatch (object &optional (table *print-pprint-dispatch*)) - (declare (type (or pprint-dispatch-table null) table) - (ext:check-arguments-type) - #.+ecl-safe-declarations+) - (let* ((table (or table *initial-pprint-dispatch*)) - (cons-entry - (and (consp object) - (gethash (car object) - (pprint-dispatch-table-cons-entries table)))) - (entry - (dolist (entry (pprint-dispatch-table-entries table) cons-entry) - (when (and cons-entry - (entry< entry cons-entry)) - (return cons-entry)) - (when (typep object (pprint-dispatch-entry-type entry)) - (return entry))))) - (if entry - (values (pprint-dispatch-entry-function entry) t) - (values #'default-pprint-dispatch nil)))) - -(defun set-pprint-dispatch (type function &optional - (priority 0) (table *print-pprint-dispatch*)) - (declare (type t type) - (type (or null function symbol) function) - (type real priority) - (type pprint-dispatch-table table)) - (when (pprint-dispatch-table-read-only-p table) - (cerror "Ignore and continue" - "Tried to modify a read-only pprint dispatch table: ~A" - table)) - ;; FIXME! This check should be automatically generated when compiling - ;; with high enough safety mode. - (unless (typep priority 'real) - (error 'simple-type-error - :format-control "Not a valid priority for set-pprint-dispatch: ~A" - :format-arguments (list priority) - :expected-type 'real - :datum priority)) - (if function - (if (cons-type-specifier-p type) - (setf (gethash (second (second type)) - (pprint-dispatch-table-cons-entries table)) - (make-pprint-dispatch-entry :type type :priority priority - :function function)) - (let ((list (delete type (pprint-dispatch-table-entries table) - :key #'pprint-dispatch-entry-type - :test #'equal)) - (entry (make-pprint-dispatch-entry - :type type - :priority priority :function function))) - (do ((prev nil next) - (next list (cdr next))) - ((null next) - (if prev - (setf (cdr prev) (list entry)) - (setf list (list entry)))) - (when (entry< (car next) entry) - (if prev - (setf (cdr prev) (cons entry next)) - (setf list (cons entry next))) - (return))) - (setf (pprint-dispatch-table-entries table) list))) - (if (cons-type-specifier-p type) - (remhash (second (second type)) - (pprint-dispatch-table-cons-entries table)) - (setf (pprint-dispatch-table-entries table) - (delete type (pprint-dispatch-table-entries table) - :key #'pprint-dispatch-entry-type - :test #'equal)))) - nil) - -;;; The guts of print-unreadable-object, inspired by SBCL. This is -;;; a redefinition of the function in iolib.lisp which add support -;;; for pprint-logical-block. -(defun %print-unreadable-object (object stream type identity body) - (cond (*print-readably* - (error 'print-not-readable :object object)) - ((and *print-pretty* (pretty-stream-p stream)) - (pprint-logical-block (stream nil :prefix "#<" :suffix ">") - (print-unreadable-object-contents object stream type identity body))) - (t - (let ((stream (cond ((null stream) - *standard-output*) - ((eq t stream) - *terminal-io*) - (t - stream)))) - (write-string "#<" stream) - (print-unreadable-object-contents object stream type identity body) - (write-char #\> stream)))) - nil) diff --git a/src/lisp/kernel/lsp/top.lisp b/src/lisp/kernel/lsp/top.lisp index a1b3cc21ca..e36ce6f705 100644 --- a/src/lisp/kernel/lsp/top.lisp +++ b/src/lisp/kernel/lsp/top.lisp @@ -59,284 +59,284 @@ ;;; A command is a list (commands function nature short-help long-help). (defconstant-equal tpl-commands '(("Top level commands" - ((:cf :compile-file) tpl-compile-command :string - ":cf Compile file" - ":compile-file &string &rest files [Top level command]~@ - :cf &string &rest files [Abbreviation]~@ - ~@ - Compile files. With no arguments, uses values from latest :cf~@ - command. File extensions are optional.~%") + ((:compile-file :cf) tpl-compile-command :string + "Compile file" + ":compile-file &string &rest files [Top level command] +:cf &string &rest files [Abbreviation] + +Compile files. With no arguments, uses values from latest :cf +command. File extensions are optional.~%") ((:exit :eof) quit :eval - ":exit or ^D Exit Lisp" - ":exit &eval &optional (status 0) [Top level command]~@ - ~@ - Exit Lisp without further confirmation.~%") - ((:ld :load) tpl-load-command :string - ":ld Load file" - ":load &string &rest files [Top level command]~@ - :ld &string &rest files [Abbreviation]~@ - ~@ - Load files. With no arguments, uses values from latest :ld~@ - or :cf command. File extensions are optional.~%") + "Exit Lisp" + ":exit &eval &optional (status 0) [Top level command] + +Exit Lisp without further confirmation.~%") + ((:load :ld) tpl-load-command :string + "Load file" + ":load &string &rest files [Top level command] +:ld &string &rest files [Abbreviation] + +Load files. With no arguments, uses values from latest :ld +or :cf command. File extensions are optional.~%") ((:step) tpl-step-command nil - ":step Single step form" - ":step form [Top level command]~@ - ~@ - Evaluate form in single step mode. While stepping, a new break~@ - level is invoked before every evaluation. Extra commands are~@ - available at this time to control stepping and form evaluation.~%") - ((:pwd :print-working-directory) tpl-default-pathname-defaults-command nil - ":pwd Print the current value of *default-pathname-defaults*" + "Single step form" + ":step form [Top level command] + +Evaluate form in single step mode. While stepping, a new break +level is invoked before every evaluation. Extra commands are +available at this time to control stepping and form evaluation.~%") + ((:pwd) tpl-default-pathname-defaults-command nil + "Print the current value of *default-pathname-defaults*" "See also: :cd.~%") - ((:cd :change-default-pathname-defaults) tpl-change-default-pathname-defaults-dir-command :string - ":cd Change the current value of *default-pathname-defaults*" + ((:cd) tpl-change-default-pathname-defaults-dir-command :string + "Change the current value of *default-pathname-defaults*" "See also: :dpd.~%") #+threads - ((:s :switch) tpl-switch-command nil - ":s(witch) Switch to next process to debug" - ":switch process [Break command]~@ - :s processs [Abbreviation]~@ - ~@ - Switch to next process in need to debugger attention. Argument~@ - process, when provided, must be an integer indicating the rank~@ - of the process in the debugger waiting list.~%") + ((:switch :s) tpl-switch-command nil + "Switch to next process to debug" + ":switch process [Break command] +:s processs [Abbreviation] + +Switch to next process in need to debugger attention. Argument +process, when provided, must be an integer indicating the rank +of the process in the debugger waiting list.~%") #+threads - ((:br :break) tpl-interrupt-command nil - ":br(eak) Stop a given process" - ":break process [Break command]~@ - :br processs [Abbreviation]~@ - ~@ - Interrupt a given process. Argument process, must be provided and - it must be an integer indicating the rank~@ - of the process in the debugger waiting list (:waiting).~%") + ((:break :br) tpl-interrupt-command nil + "Stop a given process" + ":break process [Break command] +:br processs [Abbreviation] + +Interrupt a given process. Argument process, must be provided and + it must be an integer indicating the rank +of the process in the debugger waiting list (:waiting).~%") #+threads - ((:w :waiting) tpl-waiting-command nil - ":w(aiting) Display list of active toplevels" - ":waiting [Break command]~@ - :w [Abbreviation]~@ - ~@ - Display list of active toplevels, including open debug sessions.~%") + ((:waiting :w) tpl-waiting-command nil + "Display list of active toplevels" + ":waiting [Break command] +:w [Abbreviation] + +Display list of active toplevels, including open debug sessions.~%") ) ("Help commands" ((:apropos) tpl-apropos-command nil - ":apropos Apropos" - ":apropos string &optional package [Top level command]~@ - ~@ - Finds all available symbols whose print names contain string.~@ - If a non NIL package is specified, only symbols in that package are considered.~@ - ~%") - ((:doc document) tpl-document-command nil - ":doc(ument) Document" - ":document symbol [Top level command]~@ - ~@ - Displays documentation about function, print names contain string.~%") - ((? :h :help) tpl-help-command nil - ":h(elp) or ? Help. Type \":help help\" for more information" - ":help &optional topic [Top level command]~@ - :h &optional topic [Abbreviation]~@ - ~@ - Print information on specified topic. With no arguments, print~@ - quick summary of top level commands.~@ - ~@ - Help information for top level commands follows the documentation~@ - style found in \"Common Lisp, the Language\"; and, in general, the~@ - commands themselves follow the conventions of Common Lisp functions,~@ - with the exception that arguments are normally not evaluated.~@ - Those commands that do evaluate their arguments are indicated by the~@ - keyword &eval in their description. A third class of commands~@ - treat their arguments as whitespace-separated, case-sensitive~@ - strings, requiring double quotes only when necessary. This style~@ - of argument processing is indicated by the keyword &string.~@ - For example, the :load command accepts a list of file names: - ~@ - :load &string &rest files [Top level Command]~@ - ~@ - whereas :exit, which requires an optional evaluated argument, is~@ - ~@ - :exit &eval &optional status [Top level Command]~%") + "Apropos" + ":apropos string &optional package [Top level command] + +Finds all available symbols whose print names contain string. +If a non NIL package is specified, only symbols in that package are considered. +~%") + ((:document :doc) tpl-document-command nil + "Document" + ":document symbol [Top level command] + +Displays documentation about function, print names contain string.~%") + ((:help :h ?) tpl-help-command nil + "Help. Type \":help help\" for more information" + ":help &optional topic [Top level command] +:h &optional topic [Abbreviation] + +Print information on specified topic. With no arguments, print +quick summary of top level commands. + +Help information for top level commands follows the documentation +style found in \"Common Lisp, the Language\"; and, in general, the +commands themselves follow the conventions of Common Lisp functions, +with the exception that arguments are normally not evaluated. +Those commands that do evaluate their arguments are indicated by the +keyword &eval in their description. A third class of commands +treat their arguments as whitespace-separated, case-sensitive +strings, requiring double quotes only when necessary. This style +of argument processing is indicated by the keyword &string. +For example, the :load command accepts a list of file names: + +:load &string &rest files [Top level Command] + +whereas :exit, which requires an optional evaluated argument, is + +:exit &eval &optional status [Top level Command]~%") ))) (defparameter *tpl-commands* tpl-commands) (defconstant-equal break-commands '("Break commands" - ((:q :quit) tpl-quit-command nil - ":q(uit) Return to some previous break level" - ":quit &optional n [Break command]~@ - :q &optional n [Abbreviation]~@ - ~@ - Without argument, return to top level;~@ - otherwise return to break level n.~%") + ((:quit :q) tpl-quit-command nil + "Return to some previous break level" + ":quit &optional n [Break command] +:q &optional n [Abbreviation] + +Without argument, return to top level; +otherwise return to break level n.~%") ((:pop) (tpl-pop-command) :constant - ":pop Pop to previous break level" - ":pop [Break command]~@ - ~@ - Pop to previous break level, or if already in top level,~@ - exit Lisp after confirmation.~%") - ((:c :continue) continue nil - ":c(ontinue) Continue execution" - ":continue [Break command]~@ - :c [Abbreviation]~@ - ~@ - Continue execution. Return from current break level to the caller.~@ - This command is only available when the break level is continuable~@ - (i.e., the CONTINUE restart is available).~%") - ((:b :backtrace) tpl-backtrace nil - ":b(acktrace) Print backtrace" - ":backtrace &optional count [Break command]~@ - :b &optional count [Abbreviation]~@ - ~@ - Show function call history. Only those functions called since~@ - the previous break level are shown. In addition, functions compiled~@ - in-line or explicitly hidden are not displayed. If a count is~@ - provided, only up to that many frames are displayed.~@ - See also: :function, :previous, :next.~%") - ((:r :restarts) tpl-restarts nil - ":r(estarts) Print available restarts" - ":restarts [Break command]~@ - :r [Abbreviation]~@ - Display the list of available restarts again. A restart can be~@ - invoked by using the :rN command, where N is the displayed~@ - numerical identifier for that restart.~%") - ((:f :frame) tpl-print-current nil - ":f(rame) Show current frame" - ":frame [Break command]~@ - :f [Abbreviation]~@ - ~@ - Show current frame. The current frame is the implicit focus~@ - of attention for several other commands.~@ - ~@ - See also: :backtrace, :next, previous, :disassemble, :variables.~%") - ((:u :up) tpl-previous nil - ":u(p) Go to previous frame" - ":up &optional (n 1) [Break command]~@ - :u &optional (n 1) [Abbreviation]~@ - ~@ - Move to the nth previous visible frame in the backtrace.~@ - It becomes the new current frame.~@ - ~@ - See also: :backtrace, :frame, :go, :next.~%") - ((:d :down) tpl-next nil - ":d(own) Go to next frame" - ":down &optional (n 1) [Break command]~@ - :d &optional (n 1) [Abbreviation]~@ - ~@ - Move to the nth next visible frame in the backtrace. It becomes~@ - the new current frame.~@ - ~@ - See also: :backtrace, :frame, :go, :previous.~%") - ((:g :go) tpl-go nil - ":g(o) Go to frame" - ":go &optional (n 1) [Break command]~@ - :g &optional (n 1) [Abbreviation]~@ - ~@ - Move to the i-th frame.~@ - See also: :backtrace, :frame, :next, :previous.~%") + "Pop to previous break level" + ":pop [Break command] + +Pop to previous break level, or if already in top level, +exit Lisp after confirmation.~%") + ((:continue :c) continue nil + "Continue execution" + ":continue [Break command] +:c [Abbreviation] + +Continue execution. Return from current break level to the caller. +This command is only available when the break level is continuable +(i.e., the CONTINUE restart is available).~%") + ((:backtrace :b) tpl-backtrace nil + "Print backtrace" + ":backtrace &optional count [Break command] +:b &optional count [Abbreviation] + +Show function call history. Only those functions called since +the previous break level are shown. In addition, functions compiled +in-line or explicitly hidden are not displayed. If a count is +provided, only up to that many frames are displayed. +See also: :function, :previous, :next.~%") + ((:restarts :r) tpl-restarts nil + "Print available restarts" + ":restarts [Break command] +:r [Abbreviation] +Display the list of available restarts again. A restart can be +invoked by using the :rN command, where N is the displayed +numerical identifier for that restart.~%") + ((:frame :f) tpl-print-current nil + "Show current frame" + ":frame [Break command] +:f [Abbreviation] + +Show current frame. The current frame is the implicit focus +of attention for several other commands. + +See also: :backtrace, :next, previous, :disassemble, :variables.~%") + ((:up :u) tpl-previous nil + "Go to previous frame" + ":up &optional (n 1) [Break command] +:u &optional (n 1) [Abbreviation] + +Move to the nth previous visible frame in the backtrace. +It becomes the new current frame. + +See also: :backtrace, :frame, :go, :next.~%") + ((:down :d) tpl-next nil + "Go to next frame" + ":down &optional (n 1) [Break command] +:d &optional (n 1) [Abbreviation] + +Move to the nth next visible frame in the backtrace. It becomes +the new current frame. + +See also: :backtrace, :frame, :go, :previous.~%") + ((:go :g) tpl-go nil + "Go to frame" + ":go &optional (n 1) [Break command] +:g &optional (n 1) [Abbreviation] + +Move to the i-th frame. +See also: :backtrace, :frame, :next, :previous.~%") #+(or) - ((:fs :forward-search) tpl-forward-search :string - ":fs Search forward for function" - ":forward-search &string substring [Break command]~@ - :fs &string substring [Abbreviation]~@ - ~@ - Search forward in the backtrace for function containing substring.~@ - The match is case insensitive.~@ - ~@ - See also: :backtrace, :function, :next.~%") + ((:forward-search :fs) tpl-forward-search :string + "Search forward for function" + ":forward-search &string substring [Break command] +:fs &string substring [Abbreviation] + +Search forward in the backtrace for function containing substring. +The match is case insensitive. + +See also: :backtrace, :function, :next.~%") #+(or) - ((:bs :backward-search) tpl-backward-search :string - ":bs Search backward for function" - ":backward-search &string substring [Break command]~@ - :bs &string substring [Abbreviation]~@ - ~@ - Search backward in the backtrace for function containing substring.~@ - The match is case insensitive.~@ - ~@ - See also: :backtrace, :function, :previous.~%") + ((:backward-search :bs) tpl-backward-search :string + "Search backward for function" + ":backward-search &string substring [Break command] +:bs &string substring [Abbreviation] + +Search backward in the backtrace for function containing substring. +The match is case insensitive. + +See also: :backtrace, :function, :previous.~%") ((:disassemble) tpl-disassemble-command nil - ":disassemble Disassemble current function" - ":disassemble [Break command]~@ - :disassemble [Abbreviation]~@ - ~@ - Disassemble the current frame's function, if possible.~%") - ((:le :lambda-expression) tpl-lambda-expression-command nil - ":l(ambda-)e(expression) Show lisp code for current function" - ":lambda-expression [Break command]~@ - :le [Abbreviation]~@ - ~@ - Show the lisp code of the current frame's function.~@ - Only works for interpreted functions.~%") - ((:v :variables) tpl-variables-command nil - ":v(ariables) Show local variables, functions, blocks, and tags" - ":variables &optional no-values [Break command]~@ - :v &optional no-values [Abbreviation]~@ - ~@ - Show lexical variables, functions, block names, and tags local~@ - to the current function. The current function must be interpreted.~@ - The values of local variables and functions are also shown,~@ - unless the argument is non-null.~%") + "Disassemble current function" + ":disassemble [Break command] +:disassemble [Abbreviation] + +Disassemble the current frame's function, if possible.~%") + ((:lambda-expression :le) tpl-lambda-expression-command nil + "Show lisp code for current function" + ":lambda-expression [Break command] +:le [Abbreviation] + +Show the lisp code of the current frame's function. +Only works for interpreted functions.~%") + ((:variables :v) tpl-variables-command nil + "Show local variables, functions, blocks, and tags" + ":variables &optional no-values [Break command] +:v &optional no-values [Abbreviation] + +Show lexical variables, functions, block names, and tags local +to the current function. The current function must be interpreted. +The values of local variables and functions are also shown, +unless the argument is non-null.~%") ((:hide) tpl-hide nil - ":hide Hide function" - ":hide function [Break command]~@ - ~@ - Hide function. A hidden function is not displayed in a backtrace.~@ - ~@ - See also: :backtrace, :unhide, :hide-package.~%") + "Hide function" + ":hide function [Break command] + +Hide function. A hidden function is not displayed in a backtrace. + +See also: :backtrace, :unhide, :hide-package.~%") ((:unhide) tpl-unhide nil - ":unhide Unhide function" - ":unhide function [Break command]~@ - ~@ - Unhide function. The specified function will be displayed in future~@ - backtraces, unless its home package is also hidden.~@ - ~@ - See also: :backtrace, :hide, :unhide-package.~%") - ((:hp :hide-package) tpl-hide-package nil - ":hp Hide package" - ":hide-package package [Break command]~@ - :hp package [Abbreviation]~@ - ~@ - Hide package. Functions in a hidden package are not displayed~@ - in a backtrace.~@ - ~@ - See also: :backtrace, :unhide-package.~%") - ((:unhp :unhide-package) tpl-unhide-package nil - ":unhp Unhide package" - ":unhide-package package [Break command]~@ - :unhp package [Abbreviation]~@ - ~@ - Unhide package. Functions in the specified package will be displayed~@ - in future backtraces, unless they are individually hidden.~@ - ~@ - See also: :backtrace, :hide-package, :hide, :unhide.~%") + "Unhide function" + ":unhide function [Break command] + +Unhide function. The specified function will be displayed in future +backtraces, unless its home package is also hidden. + +See also: :backtrace, :hide, :unhide-package.~%") + ((:hide-package :hp) tpl-hide-package nil + "Hide package" + ":hide-package package [Break command] +:hp package [Abbreviation] + +Hide package. Functions in a hidden package are not displayed +in a backtrace. + +See also: :backtrace, :unhide-package.~%") + ((:unhide-package :unhp) tpl-unhide-package nil + "Unhide package" + ":unhide-package package [Break command] +:unhp package [Abbreviation] + +Unhide package. Functions in the specified package will be displayed +in future backtraces, unless they are individually hidden. + +See also: :backtrace, :hide-package, :hide, :unhide.~%") ((:unhide-all) tpl-unhide-all nil - ":unhide-all Unhide all variables and packages" - ":unhide-all [Break command]~@ - ~@ - Unhide all variables and packages. All functions will be displayed~@ - in future backtraces.~@ - ~@ - See also: :hide, :unhide, :hide-package, :unhide-package.~%") - ((:m :message) tpl-print-message nil - ":m(essage) Show error message" - ":message [Break command]~@ - :m [Abbreviation]~@ - ~@ - Show current error message.~%") - ((:hs :help-stack) tpl-help-stack-command nil - ":hs Help stack" - ":help-stack [Break command]~@ - :hs [Abbreviation]~@ - ~@ - Lists the functions to access backtrace information more directly.~%") - ((:i :inspect) tpl-inspect-command nil - ":i(nspect) Inspect value of local variable" - ":inspect var-name [Break command]~@ - :i var-name [Abbreviation]~@ - ~@ - Inspect value of local variable named by var-name. Argument~@ - var-name can be a string or a symbol whose name string will~@ - then be used regardless of of the symbol's package.~@ - ~@ - See also: :variables.~%") + "Unhide all variables and packages" + ":unhide-all [Break command] + +Unhide all variables and packages. All functions will be displayed +in future backtraces. + +See also: :hide, :unhide, :hide-package, :unhide-package.~%") + ((:message :m) tpl-print-message nil + "Show error message" + ":message [Break command] +:m [Abbreviation] + +Show current error message.~%") + ((:help-stack :hs) tpl-help-stack-command nil + "Help stack" + ":help-stack [Break command] +:hs [Abbreviation] + +Lists the functions to access backtrace information more directly.~%") + ((:inspect :i) tpl-inspect-command nil + "Inspect value of local variable" + ":inspect var-name [Break command] +:i var-name [Abbreviation] + +Inspect value of local variable named by var-name. Argument +var-name can be a string or a symbol whose name string will +then be used regardless of of the symbol's package. + +See also: :variables.~%") )) (defun top-level (&key set-package (noprint (core:noprint-p))) @@ -410,12 +410,11 @@ The top-level loop of Clasp. It is called by default when Clasp is invoked." #+threads (defun show-process-list (&optional (process-list (mp:all-processes))) (loop with current = mp:*current-process* - for rank from 1 - for process in process-list - do (format t (if (eq process current) - "~% >~D: ~s" - "~% ~D: ~s") - rank process))) + for rank from 1 + for process in process-list + do (format t "~% ~:[ ~;>~]~D: ~s" + (eq process current) + rank process))) #+threads (defun query-process (&optional (process-list (mp:all-processes))) @@ -832,28 +831,49 @@ Use special code 0 to cancel this operation.") (dolist (file *tpl-last-compile*) (compile-file file)) (setq *tpl-last-load* *tpl-last-compile*)) +(defun write-descriptions (stream commands) + (loop with labels = (loop for group in commands + collect (loop for command in (cdr group) + collect (format nil "~{~#[~;~a~;~a or ~a~:;~@{~a~#[~;, or ~:;, ~]~}~]~}" + + (mapcar (lambda (name) + (if (eq name :eof) + "^D" + (write-to-string name + :readably t + :escape nil + :case :downcase))) + (car command))))) + with width = (+ 4 + (loop for group in labels + maximize (loop for label in group + maximize (length label)))) + for group in commands + for label-group in labels + do (format t "~%~A:~%" (car group)) + (loop for command in (cdr group) + for label in label-group + do (format stream "~a~vt~a~%" + label width (fourth command))))) + (defun tpl-help-command (&optional topic) (cond ((null topic) - (dolist (commands *tpl-commands*) - (format t "~%~A:~%" (car commands)) - (dolist (c (cdr commands)) - (when (fourth c) - (format t "~A.~%" (fourth c)))))) - ((or (stringp topic) (symbolp topic)) - (let (c) - (setq topic (intern (string topic) (find-package 'keyword))) - (dolist (commands *tpl-commands*) - (when (setq c (assoc topic (cdr commands) :test #'member)) - (return))) - (cond ((null (fifth c)) - (format t "No such help topic: ~s~%" - (string topic))) - (t - (terpri) - (format t (fifth c)) - (terpri))))) - (t - (format t "Not a valid help topic: ~s~%" topic))) + (write-descriptions t *tpl-commands*)) + ((or (stringp topic) (symbolp topic)) + (let (c) + (setq topic (intern (string topic) (find-package 'keyword))) + (dolist (commands *tpl-commands*) + (when (setq c (assoc topic (cdr commands) :test #'member)) + (return))) + (cond ((null (fifth c)) + (format t "No such help topic: ~s~%" + (string topic))) + (t + (terpri) + (write-line t (fifth c)) + (terpri))))) + (t + (format t "Not a valid help topic: ~s~%" topic))) (values)) (defun tpl-help-stack-command () @@ -866,30 +886,27 @@ Use special code 0 to cancel this operation.") See the CLASP-DEBUG package for more information about FRAME objects.") (values)) -(defun compute-restart-commands (condition &key display) - (let ((restarts (compute-restarts condition)) - (restart-commands (list "Restart commands"))) - (when display - (format display - (if restarts - "~&Available restarts:~&(use :r1 to invoke restart 1, etc.)~2%" - "~&No restarts available.~%"))) - (loop for restart in restarts - and i from 1 - do (let ((user-command (format nil "r~D" i)) - (name (format nil "~@[(~A)~]" (restart-name restart))) - (helpstring (princ-to-string restart))) - (push (list - (list (intern (string-upcase user-command) :keyword)) - restart :restart - (format nil ":~A~16T~A~24T~A" user-command helpstring name) - (format nil ":~A~48T~A~& ~&~A~A" (string-downcase user-command) - "[Restart command]" name helpstring)) - restart-commands) - (when display - (format display "~D. ~A ~A~%" i name restart)))) - (when display (terpri display)) - (nreverse restart-commands))) +(defun write-restart-banner (stream restart-commands) + (if restart-commands + (write-descriptions stream (list restart-commands)) + (format stream "~2&No restarts available.")) + (terpri)) + +(defun compute-restart-commands (condition) + (loop with restarts = (compute-restarts condition) + for restart in restarts + for i from 1 + for user-command = (format nil "r~D" i) + for name = (format nil "~@[(~A)~]" (restart-name restart)) + for helpstring = (princ-to-string restart) + when (eq i 1) + collect "Restart commands" + collect (list (list (intern (string-upcase user-command) :keyword)) + restart :restart + (format nil "~A~24T~A" helpstring name) + (format nil ":~A~48T[Restart command]~& ~&~A~A" + (string-downcase user-command) + name helpstring)))) (defun update-debug-commands (restart-commands) (let ((commands (copy-list *tpl-commands*))) @@ -902,18 +919,10 @@ See the CLASP-DEBUG package for more information about FRAME objects.") (defun tpl-restarts () ;; Make sure this displays consistently with compute-restart-commands. - (let ((restart-commands (cdr (assoc "Restart commands" *tpl-commands* - :test #'string=)))) - (format t (if restart-commands - "~&Available restarts:~&(use :r1 to invoke restart 1, etc.)~2%" - "~&No restarts available.~%")) - (loop for command in restart-commands - for restart = (second command) - for i from 1 - do (format t "~d. ~@[(~a)~] ~a~%" - i (restart-name restart) restart))) - (terpri) - (values)) + (let ((restart-commands (assoc "Restart commands" *tpl-commands* + :test #'string=))) + (write-restart-banner t restart-commands) + (values))) (defparameter *default-debugger-maximum-depth* 16) @@ -969,14 +978,14 @@ See the CLASP-DEBUG package for more information about FRAME objects.") (*terminal-io* *debug-io*) (*query-io* *debug-io*) ;;(*tpl-prompt-hook* "[dbg] ") - (*print-readably* nil) + (*print-readably* nil) (*print-pretty* nil) (*print-circle* t) (*print-length* 16) (*readtable* (or *break-readtable* *readtable*)) - (*break-condition* condition) + (*break-condition* condition) (*break-message* (format nil "~&Condition of type: ~A~%~A~%" - (type-of condition) + (type-of condition) (princ-condition-to-string condition))) (*break-level* (1+ *break-level*)) (break-level *break-level*) @@ -1005,10 +1014,10 @@ See the CLASP-DEBUG package for more information about FRAME objects.") ;; Here we show a list of restarts and invoke the toplevel with ;; an extended set of commands which includes invoking the associated ;; restarts. - (let* ((restart-commands (compute-restart-commands - condition :display *error-output*)) + (let* ((restart-commands (compute-restart-commands condition)) (debug-commands - (update-debug-commands restart-commands))) + (update-debug-commands restart-commands))) + (write-restart-banner *error-output* restart-commands) (clasp-debug:with-stack (*break-base*) (let ((*break-frame* (clasp-debug:visible *break-base*))) (tpl :commands debug-commands)))))))) diff --git a/src/lisp/modules/sockets/sockets.lisp b/src/lisp/modules/sockets/sockets.lisp index a85c6e1aa7..ade88c7cdd 100755 --- a/src/lisp/modules/sockets/sockets.lisp +++ b/src/lisp/modules/sockets/sockets.lisp @@ -760,14 +760,14 @@ GET-NAME-SERVICE-ERRNO") `(progn (export ',name) (defun ,name (socket) - (,(intern (format nil "GET-SOCKOPT-~A" type)) + (,(intern (concatenate 'string (string '#:get-sockopt-) (string type))) (socket-file-descriptor socket) ,c-level ,c-const )) ,@(unless read-only `((defun (setf ,name) (value socket) - (,(intern (format nil "SET-SOCKOPT-~A" type)) + (,(intern (concatenate 'string (string '#:set-sockopt-) (string type))) (socket-file-descriptor socket) ,c-level ,c-const diff --git a/src/lisp/regression-tests/misc.lisp b/src/lisp/regression-tests/misc.lisp index 118a1dc0e9..3e877edcb8 100644 --- a/src/lisp/regression-tests/misc.lisp +++ b/src/lisp/regression-tests/misc.lisp @@ -289,7 +289,7 @@ ;;; (LOOP (fu) nil (bar)) which is not acceptable. To verify ;;; that this is not happening we make sure we are not getting ;;; (BLOCK NIL NIL) since this is easier to test for. -(test format-no-nil-form +#+(or)(test format-no-nil-form (third (second (macroexpand-1 '(formatter "~ ")))) ((block nil))) diff --git a/src/lisp/regression-tests/printer01.lisp b/src/lisp/regression-tests/printer01.lisp index 12ae0815a1..5e4d8cac2c 100644 --- a/src/lisp/regression-tests/printer01.lisp +++ b/src/lisp/regression-tests/printer01.lisp @@ -595,120 +595,120 @@ BBBBCCCC**DDDD")) (test cdr-7.comma.1.interpreted (with-standard-io-syntax - (format nil (progn "~1,2/clasp-tests:fmt/") t)) + (format nil (progn "~1,2/clasp-tests::fmt/") t)) ("(1 2)")) (test cdr-7.comma.1.compiled (with-standard-io-syntax - (format nil "~1,2/clasp-tests:fmt/" t)) + (format nil "~1,2/clasp-tests::fmt/" t)) ("(1 2)")) (test cdr-7.comma.2.interpreted (with-standard-io-syntax - (format nil (progn "~1,2,/clasp-tests:fmt/") t)) + (format nil (progn "~1,2,/clasp-tests::fmt/") t)) ("(1 2)")) (test cdr-7.comma.2.compiled (with-standard-io-syntax - (format nil "~1,2,/clasp-tests:fmt/" t)) + (format nil "~1,2,/clasp-tests::fmt/" t)) ("(1 2)")) (test cdr-7.comma.3.interpreted (with-standard-io-syntax - (format nil (progn "~1,2:/clasp-tests:fmt/") t)) + (format nil (progn "~1,2:/clasp-tests::fmt/") t)) ("(1 2)")) (test cdr-7.comma.3.compiled (with-standard-io-syntax - (format nil "~1,2:/clasp-tests:fmt/" t)) + (format nil "~1,2:/clasp-tests::fmt/" t)) ("(1 2)")) (test cdr-7.comma.4.interpreted (with-standard-io-syntax - (format nil (progn "~1,2,:/clasp-tests:fmt/") t)) + (format nil (progn "~1,2,:/clasp-tests::fmt/") t)) ("(1 2)")) (test cdr-7.comma.4.compiled (with-standard-io-syntax - (format nil "~1,2,:/clasp-tests:fmt/" t)) + (format nil "~1,2,:/clasp-tests::fmt/" t)) ("(1 2)")) (test cdr-7.parameter.1.interpreted (with-standard-io-syntax - (format nil (progn "~1,v/clasp-tests:fmt/") 2 t)) + (format nil (progn "~1,v/clasp-tests::fmt/") 2 t)) ("(1 2)")) (test cdr-7.parameter.1.compiled (with-standard-io-syntax - (format nil "~1,v/clasp-tests:fmt/" 2 t)) + (format nil "~1,v/clasp-tests::fmt/" 2 t)) ("(1 2)")) (test cdr-7.parameter.2.interpreted (with-standard-io-syntax - (format nil (progn "~1,v/clasp-tests:fmt/") nil t)) + (format nil (progn "~1,v/clasp-tests::fmt/") nil t)) ("(1 NIL)")) (test cdr-7.parameter.2.compiled (with-standard-io-syntax - (format nil "~1,v/clasp-tests:fmt/" nil t)) + (format nil "~1,v/clasp-tests::fmt/" nil t)) ("(1 NIL)")) (test cdr-7.parameter.3.interpreted (with-standard-io-syntax - (format nil (progn "~1,v,/clasp-tests:fmt/") 2 t)) + (format nil (progn "~1,v,/clasp-tests::fmt/") 2 t)) ("(1 2)")) (test cdr-7.parameter.3.compiled (with-standard-io-syntax - (format nil "~1,v,/clasp-tests:fmt/" 2 t)) + (format nil "~1,v,/clasp-tests::fmt/" 2 t)) ("(1 2)")) (test cdr-7.parameter.4.interpreted (with-standard-io-syntax - (format nil (progn "~1,v,/clasp-tests:fmt/") nil t)) + (format nil (progn "~1,v,/clasp-tests::fmt/") nil t)) ("(1 NIL)")) (test cdr-7.parameter.4.compiled (with-standard-io-syntax - (format nil "~1,v,/clasp-tests:fmt/" nil t)) + (format nil "~1,v,/clasp-tests::fmt/" nil t)) ("(1 NIL)")) (test cdr-7.parameter.5.interpreted (with-standard-io-syntax - (format nil (progn "~1,v:/clasp-tests:fmt/") 2 t)) + (format nil (progn "~1,v:/clasp-tests::fmt/") 2 t)) ("(1 2)")) (test cdr-7.parameter.5.compiled (with-standard-io-syntax - (format nil "~1,v:/clasp-tests:fmt/" 2 t)) + (format nil "~1,v:/clasp-tests::fmt/" 2 t)) ("(1 2)")) (test cdr-7.parameter.6.interpreted (with-standard-io-syntax - (format nil (progn "~1,v:/clasp-tests:fmt/") nil t)) + (format nil (progn "~1,v:/clasp-tests::fmt/") nil t)) ("(1 NIL)")) (test cdr-7.parameter.6.compiled (with-standard-io-syntax - (format nil "~1,v:/clasp-tests:fmt/" nil t)) + (format nil "~1,v:/clasp-tests::fmt/" nil t)) ("(1 NIL)")) (test cdr-7.parameter.7.interpreted (with-standard-io-syntax - (format nil (progn "~1,v,:/clasp-tests:fmt/") 2 t)) + (format nil (progn "~1,v,:/clasp-tests::fmt/") 2 t)) ("(1 2)")) (test cdr-7.parameter.7.compiled (with-standard-io-syntax - (format nil "~1,v,:/clasp-tests:fmt/" 2 t)) + (format nil "~1,v,:/clasp-tests::fmt/" 2 t)) ("(1 2)")) (test cdr-7.parameter.8.interpreted (with-standard-io-syntax - (format nil (progn "~1,v,:/clasp-tests:fmt/") nil t)) + (format nil (progn "~1,v,:/clasp-tests::fmt/") nil t)) ("(1 NIL)")) (test cdr-7.parameter.8.compiled (with-standard-io-syntax - (format nil "~1,v,:/clasp-tests:fmt/" nil t)) + (format nil "~1,v,:/clasp-tests::fmt/" nil t)) ("(1 NIL)")) diff --git a/src/lisp/regression-tests/read01.lisp b/src/lisp/regression-tests/read01.lisp index 0029a4c292..20b3bc0865 100644 --- a/src/lisp/regression-tests/read01.lisp +++ b/src/lisp/regression-tests/read01.lisp @@ -12,25 +12,50 @@ (push (read-from-string "1.111") result)))) ((1.111s0 1.111f0 1.111d0 1.111l0))) -(test read-2 - (ext:with-float-traps-masked (:invalid :overflow :underflow :divide-by-zero) - (with-output-to-string (*standard-output*) - (let ((*read-default-float-format* 'single-float) - (*print-readably* nil)) - (print (read-from-string (format nil "12~40,2f" most-positive-single-float)))))) - (" -#.ext:single-float-positive-infinity ")) - -(test-true read-3 - (ext:with-float-traps-masked (:invalid :overflow :underflow :divide-by-zero) - (string-equal - (concatenate 'string (string #\Newline) - "#.ext:double-float-positive-infinity ") - (with-output-to-string (*standard-output*) - (let ((*read-default-float-format* 'double-float) - (*print-readably* nil)) - (print (read-from-string (format nil "12~308,2f" most-positive-double-float)))))))) - +(defun print-infinity (value) + (string-trim '(#\space #\newline #\tab #\return) + (with-output-to-string (*standard-output*) + (let ((*read-default-float-format* (type-of value)) + (*print-readably* t)) + (ext:with-float-traps-masked + (:invalid :overflow :underflow :divide-by-zero) + (print (read-from-string (format nil "~,,1f" value)))))))) + +#+short-float +(test-true read-2-short + (string-equal "#.ext:short-float-positive-infinity" + (print-infinity most-positive-short-float))) + +(test-true read-2-single + (string-equal "#.ext:single-float-positive-infinity" + (print-infinity most-positive-single-float))) + +(test-true read-2-double + (string-equal "#.ext:double-float-positive-infinity" + (print-infinity most-positive-double-float))) + +#+long-float +(test-true read-2-long + (string-equal "#.ext:long-float-positive-infinity" + (print-infinity most-positive-long-float))) + +#+short-float +(test-true read-3-short + (string-equal "#.ext:short-float-negative-infinity" + (print-infinity most-negative-short-float))) + +(test-true read-3-single + (string-equal "#.ext:single-float-negative-infinity" + (print-infinity most-negative-single-float))) + +(test-true read-3-double + (string-equal "#.ext:double-float-negative-infinity" + (print-infinity most-negative-double-float))) + +#+long-float +(test-true read-4-long + (string-equal "#.ext:long-float-negative-infinity" + (print-infinity most-negative-long-float))) ;;; Reader-errors diff --git a/src/lisp/regression-tests/set-unexpected-failures.lisp b/src/lisp/regression-tests/set-unexpected-failures.lisp index 686ee33728..21517500b2 100644 --- a/src/lisp/regression-tests/set-unexpected-failures.lisp +++ b/src/lisp/regression-tests/set-unexpected-failures.lisp @@ -4,6 +4,7 @@ '(random-short random-double random-long ;; compile-file-no-unwind types-classes-10 + write-quasiquote-01 sbcl-cross-compile-4 ;;;not important ;; include-level-2a include-level-2b include-level-3 ;;; a problem for sbcl x-compiling