Skip to content

Commit ad7ca4f

Browse files
yitzchakyitzchak
committed
Add incless circle check functions to be called from C
1 parent 865316d commit ad7ca4f

5 files changed

Lines changed: 66 additions & 146 deletions

File tree

‎src/core/corePackage.cc‎

Lines changed: 2 additions & 0 deletions
Original file line numberDiff line numberDiff line change
@@ -275,6 +275,8 @@ SYMBOL_EXPORT_SC_(CorePkg, unquote_nsplice);
275275
SYMBOL_EXPORT_SC_(CorePkg, unquote_splice);
276276
SYMBOL_EXPORT_SC_(CorePkg, valist);
277277
SYMBOL_EXPORT_SC_(CorePkg, wrongNumberOfArguments);
278+
SYMBOL_SC_(CorePkg, PERCENTwrite_object);
279+
SYMBOL_SC_(CorePkg, PERCENTcircle_check);
278280
SYMBOL_SC_(CorePkg, DOT);
279281
SYMBOL_SC_(CorePkg, STARPATHSTAR);
280282
SYMBOL_SC_(CorePkg, STARargsSTAR);

‎src/core/write_object.cc‎

Lines changed: 4 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -49,6 +49,8 @@ THE SOFTWARE.
4949
namespace core {
5050

5151
bool will_print_as_hash(T_sp x) {
52+
if (core::_sym_PERCENTcircle_check->fboundp())
53+
return ((T_sp)core::eval::funcall(core::_sym_PERCENTcircle_check, x)).notnilp();
5254
T_sp circle_counter = _sym_STARcircle_counterSTAR->symbolValue();
5355
HashTable_sp circle_stack = gc::As<HashTable_sp>(_sym_STARcircle_stackSTAR->symbolValue());
5456
T_sp code = circle_stack->gethash(x, unbound<T_O>());
@@ -141,7 +143,8 @@ T_sp do_write_object_circle(T_sp x, T_sp stream) {
141143
}
142144

143145
T_sp write_object(T_sp x, T_sp stream) {
144-
// With *print-pretty*, go immediately to the pretty printer, which does its own *print-circle* etc.
146+
if (core::_sym_PERCENTwrite_object->fboundp())
147+
return core::eval::funcall(core::_sym_PERCENTwrite_object, x, stream);
145148
if (!cl::_sym_STARprint_prettySTAR.unboundp() && cl::_sym_STARprint_prettySTAR->boundP() &&
146149
cl::_sym_STARprint_prettySTAR->symbolValue().notnilp()) {
147150
T_mv mv_f = eval::funcall(cl::_sym_pprint_dispatch, x);

‎src/lisp/kernel/lsp/describe.lisp‎

Lines changed: 50 additions & 51 deletions
Original file line numberDiff line numberDiff line change
@@ -55,17 +55,17 @@
5555
(defun select-? ()
5656
(terpri)
5757
(format t
58-
"Inspect commands:~%~
59-
n (or N or Newline): inspects the field (recursively).~%~
60-
s (or S): skips the field.~%~
61-
p (or P): pretty-prints the field.~%~
62-
a (or A): aborts the inspection ~
63-
of the rest of the fields.~%~
64-
u (or U) form: updates the field ~
65-
with the value of the form.~%~
66-
e (or E) form: evaluates and prints the form.~%~
67-
q (or Q): quits the inspection.~%~
68-
?: prints this.~%~%"))
58+
"Inspect commands:~@
59+
n (or N or Newline): inspects the field (recursively).~@
60+
s (or S): skips the field.~@
61+
p (or P): pretty-prints the field.~@
62+
a (or A): aborts the inspection ~
63+
of the rest of the fields.~@
64+
u (or U) form: updates the field ~
65+
with the value of the form.~@
66+
e (or E) form: evaluates and prints the form.~@
67+
q (or Q): quits the inspection.~@
68+
?: prints this.~2%"))
6969

7070
(defun read-inspect-command (label object allow-recursive)
7171
(declare (special *quit-tag* *quit-tags*))
@@ -258,17 +258,17 @@
258258
(defun inspect-cons (cons)
259259
(format t "~S - cons" cons)
260260
(when *inspect-mode*
261-
(do ((i 0 (1+ i))
262-
(l cons (cdr l)))
263-
((atom l)
264-
(case l
265-
((t nil) ;; no point in inspecting recursively t nor nil.
266-
(inspect-print (format nil "nthcdr ~D: ~~S" i) l))
267-
(t
268-
(inspect-recursively (format nil "nthcdr ~D:" i)
269-
l (cdr (nthcdr (1- i) cons))))))
270-
(inspect-recursively (format nil "nth ~D:" i)
271-
(car l) (nth i cons)))))
261+
(do ((i 0 (1+ i))
262+
(l cons (cdr l)))
263+
((atom l)
264+
(case l
265+
((t nil) ;; no point in inspecting recursively t nor nil.
266+
(inspect-print (format nil "nthcdr ~D: ~~S" i) l))
267+
(t
268+
(inspect-recursively (format nil "nthcdr ~D:" i)
269+
l (cdr (nthcdr (1- i) cons))))))
270+
(inspect-recursively (format nil "nth ~D:" i)
271+
(car l) (nth i cons)))))
272272

273273
(defun inspect-string (string)
274274
(format t (if (simple-string-p string) "~S - simple string" "~S - string")
@@ -468,28 +468,27 @@ q (or Q): quits the inspection.~%~
468468
(when (and (not *inspect-mode*)
469469
(or (> *inspect-level* 5)
470470
(member object *inspect-history*)))
471-
(prin1 object)
472-
(return-from inspect-object))
471+
(prin1 object)
472+
(return-from inspect-object))
473473
(incf *inspect-level*)
474474
(push object *inspect-history*)
475475
(catch 'ABORT-INSPECT
476476
(let ((* object))
477-
(cond
478-
((symbolp object) (inspect-symbol object))
479-
((packagep object) (inspect-package object))
480-
((characterp object) (inspect-character object))
481-
((numberp object) (inspect-number object))
482-
((consp object) (inspect-cons object))
483-
((stringp object) (inspect-string object))
484-
((vectorp object) (inspect-vector object))
485-
((arrayp object) (inspect-array object))
486-
((hash-table-p object) (inspect-hashtable object))
487-
;; Note that this needs to get generic functions,
488-
;; so keep it before the instancep test.
489-
((functionp object) (inspect-function object))
490-
((sys:instancep object) (inspect-instance object))
491-
((sys:cxx-object-p object) (describe-object object *standard-output*))
492-
(t (format t "~S - ~S" object (type-of object)))))))
477+
(cond ((symbolp object) (inspect-symbol object))
478+
((packagep object) (inspect-package object))
479+
((characterp object) (inspect-character object))
480+
((numberp object) (inspect-number object))
481+
((consp object) (inspect-cons object))
482+
((stringp object) (inspect-string object))
483+
((vectorp object) (inspect-vector object))
484+
((arrayp object) (inspect-array object))
485+
((hash-table-p object) (inspect-hashtable object))
486+
;; Note that this needs to get generic functions,
487+
;; so keep it before the instancep test.
488+
((functionp object) (inspect-function object))
489+
((sys:instancep object) (inspect-instance object))
490+
((sys:cxx-object-p object) (describe-object object *standard-output*))
491+
(t (format t "~S - ~S" object (type-of object)))))))
493492

494493
(defun default-inspector (object)
495494
"Args: (object)
@@ -518,17 +517,17 @@ inspect commands, or type '?' to the inspector."
518517
object)
519518

520519
(defun describe (object &optional (stream *standard-output*)
521-
&aux (*inspect-mode* nil)
522-
(*inspect-level* 0)
523-
(*inspect-history* nil)
524-
(*print-level* nil)
525-
(*print-length* nil)
526-
(*standard-output* (cond ((streamp stream) stream)
527-
((null stream) *standard-output*)
528-
((eq stream t) *terminal-io*)
529-
(t (error 'type-error
530-
:datum stream
531-
:expected-type '(or stream t nil))))))
520+
&aux (*inspect-mode* nil)
521+
(*inspect-level* 0)
522+
(*inspect-history* nil)
523+
(*print-level* nil)
524+
(*print-length* nil)
525+
(*standard-output* (cond ((streamp stream) stream)
526+
((null stream) *standard-output*)
527+
((eq stream t) *terminal-io*)
528+
(t (error 'type-error
529+
:datum stream
530+
:expected-type '(or stream t nil))))))
532531
"Args: (object &optional (stream *standard-output*))
533532
Prints information about OBJECT to STREAM."
534533
(terpri)

‎src/lisp/kernel/lsp/iolib.lisp‎

Lines changed: 0 additions & 93 deletions
Original file line numberDiff line numberDiff line change
@@ -77,99 +77,6 @@ object's representation."
7777
(values (read stream eof-error-p eof-value)
7878
(file-position stream)))))
7979

80-
;;; This function does what write-to-string does to a symbol name,
81-
;;; when printer escaping is off.
82-
;;; It's over five times as far as write-to-string.
83-
(defun printcasify (symbol-name readtable-case print-case)
84-
(let ((result (copy-seq symbol-name))
85-
(len (length symbol-name)))
86-
(case readtable-case
87-
((:preserve) result)
88-
((:invert)
89-
(dotimes (i len result)
90-
(let ((c (aref result i)))
91-
(setf (aref result i)
92-
(cond ((upper-case-p c)
93-
(char-downcase c))
94-
((lower-case-p c)
95-
(char-upcase c))
96-
(t c))))))
97-
((:upcase)
98-
(let ((capitalize t))
99-
(dotimes (i len result)
100-
(let ((c (aref result i)))
101-
(setf (aref result i)
102-
(if (and (upper-case-p c)
103-
(or (eq print-case :downcase)
104-
(and (eq print-case :capitalize)
105-
(not capitalize))))
106-
(char-downcase c)
107-
c)
108-
capitalize (not (alphanumericp c)))))))
109-
((:downcase)
110-
(let ((capitalize t))
111-
(dotimes (i len result)
112-
(let ((c (aref result i)))
113-
(setf (aref result i)
114-
(if (and (lower-case-p c)
115-
(or (eq print-case :downcase)
116-
(and (eq print-case :capitalize)
117-
capitalize)))
118-
(char-downcase c)
119-
c)
120-
capitalize (not (alphanumericp c))))))))))
121-
122-
(defun stringify (object)
123-
(when (and (not *print-escape*) (not *print-readably*) (not *print-pretty*))
124-
(cond
125-
((symbolp object)
126-
(return-from stringify
127-
(printcasify (symbol-name object)
128-
(readtable-case *readtable*)
129-
*print-case*)))
130-
((stringp object) (return-from stringify (copy-seq object)))
131-
((characterp object) (return-from stringify (string object)))))
132-
;; By not making a fresh stream every time, we save some time.
133-
(let ((stream (core:thread-local-write-to-string-output-stream)))
134-
(write-object object stream)
135-
(core:get-thread-local-write-to-string-output-stream-string stream)))
136-
137-
(defun write-to-string (object &key ((:escape *print-escape*) *print-escape*)
138-
((:radix *print-radix*) *print-radix*)
139-
((:base *print-base*) *print-base*)
140-
((:circle *print-circle*) *print-circle*)
141-
((:pretty *print-pretty*) *print-pretty*)
142-
((:level *print-level*) *print-level*)
143-
((:length *print-length*) *print-length*)
144-
((:case *print-case*) *print-case*)
145-
((:array *print-array*) *print-array*)
146-
((:gensym *print-gensym*) *print-gensym*)
147-
((:readably *print-readably*) *print-readably*)
148-
((:right-margin *print-right-margin*)
149-
*print-right-margin*)
150-
((:miser-width *print-miser-width*)
151-
*print-miser-width*)
152-
((:lines *print-lines*) *print-lines*)
153-
((:pprint-dispatch *print-pprint-dispatch*)
154-
*print-pprint-dispatch*))
155-
"Returns as a string the printed representation of OBJECT in the specified
156-
mode. See the variable docs of *PRINT-...* for the mode."
157-
(stringify object))
158-
159-
(defun prin1-to-string (object)
160-
"Args: (object)
161-
PRIN1s OBJECT to a new string and returns the result. Equivalent to
162-
(WRITE-TO-STRING OBJECT :ESCAPE T)."
163-
(let ((*print-escape* t))
164-
(stringify object)))
165-
166-
(defun princ-to-string (object)
167-
"Args: (object)
168-
PRINCs OBJECT to a new string and returns the result. Equivalent to
169-
(WRITE-TO-STRING OBJECT :ESCAPE NIL :READABLY NIL)."
170-
(let ((*print-escape* nil) (*print-readably* nil))
171-
(stringify object)))
172-
17380
(defmacro with-open-file ((stream . filespec) &rest body)
17481
"Syntax: (with-open-file (var filespec-form {options}*) {decl}* {form}*)
17582
Opens the specified file using OPTIONs, and evaluates FORMs with VAR bound to

‎src/lisp/kernel/lsp/late-printer.lisp‎

Lines changed: 10 additions & 1 deletion
Original file line numberDiff line numberDiff line change
@@ -1,7 +1,16 @@
11
(in-package #:sys)
22

3+
(defun %write-object (object stream)
4+
(incless:write-object incless-intrinsic:*client* object stream))
5+
6+
(defun %circle-check (object)
7+
(incless:circle-check incless-intrinsic:*client* object nil))
8+
9+
(defmethod print-object (object stream)
10+
(write-ugly-object object stream))
11+
312
(defmethod incless:printing-char-p ((client incless-intrinsic:client) char)
4-
(core:printing-char-p char))
13+
(printing-char-p char))
514

615
(define-compiler-macro assert-failure (&whole form &rest args)
716
(declare (ignore args))

0 commit comments

Comments
 (0)