("src/code/hash-table")
("src/code/readtable")
("src/code/pathname")
+ ("src/code/host-pprint")
("src/compiler/lexenv")
;; KLUDGE: Much stuff above here is the type system and/or the INFO
"LEGAL-FUN-NAME-P" "LEGAL-FUN-NAME-OR-TYPE-ERROR"
"FUN-NAME-BLOCK-NAME"
"FUN-NAME-INLINE-EXPANSION"
- "WHITESPACE-CHAR-P"
"LISTEN-SKIP-WHITESPACE"
"PACKAGE-INTERNAL-SYMBOL-COUNT" "PACKAGE-EXTERNAL-SYMBOL-COUNT"
"PARSE-BODY" "PARSE-LAMBDA-LIST" "PARSE-LAMBDA-LIST-LIKE-THING"
:use ("CL" "SB!EXT" "SB!INT" "SB!KERNEL")
:export ("OUTPUT-PRETTY-OBJECT"
"PRETTY-STREAM" "PRETTY-STREAM-P"
+ "PPRINT-DISPATCH-TABLE"
"!PPRINT-COLD-INIT"))
#s(sb-cold:package-data
--- /dev/null
+;;;; Common Lisp pretty printer definitions that need to be on the
+;;;; host
+
+;;;; This software is part of the SBCL system. See the README file for
+;;;; more information.
+;;;;
+;;;; This software is derived from the CMU CL system, which was
+;;;; written at Carnegie Mellon University and released into the
+;;;; public domain. The software is in the public domain and is
+;;;; provided with absolutely no warranty. See the COPYING and CREDITS
+;;;; files for more information.
+
+(in-package "SB!PRETTY")
+
+(def!struct (pprint-dispatch-table (:copier 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 <thing>)). 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)))
+(def!method print-object ((table pprint-dispatch-table) stream)
+ (print-unreadable-object (table stream :type t :identity t)))
(pprint-dispatch-entry-priority entry)
(pprint-dispatch-entry-initial-p entry))))
-(defstruct (pprint-dispatch-table (:copier 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 <thing>)). 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)))
-(def!method print-object ((table pprint-dispatch-table) stream)
- (print-unreadable-object (table stream :type t :identity t)))
-
(defun cons-type-specifier-p (spec)
(and (consp spec)
(eq (car spec) 'cons)
(defun set-pprint-dispatch (type function &optional
(priority 0) (table *print-pprint-dispatch*))
- (declare (type (or null function) function)
+ (declare (type (or null callable) function)
(type real priority)
(type pprint-dispatch-table table))
(/show0 "entering SET-PPRINT-DISPATCH, TYPE=...")
(/hexstr type)
(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
- :fun function))
- (let ((list (delete type (pprint-dispatch-table-entries table)
- :key #'pprint-dispatch-entry-type
- :test #'equal))
- (entry (make-pprint-dispatch-entry
- :type type
- :test-fn (compute-test-fn type)
- :priority priority
- :fun 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)))
+ ;; KLUDGE: this impairs debuggability, and probably isn't even
+ ;; conforming -- maybe we should not coerce to function, but
+ ;; cater downstream (in PPRINT-DISPATCH-ENTRY) for having
+ ;; callables here.
+ (let ((function (%coerce-callable-to-fun 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
+ :fun function))
+ (let ((list (delete type (pprint-dispatch-table-entries table)
+ :key #'pprint-dispatch-entry-type
+ :test #'equal))
+ (entry (make-pprint-dispatch-entry
+ :type type
+ :test-fn (compute-test-fn type)
+ :priority priority
+ :fun 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))
(character character &optional (or readtable null)) (or callable null)
())
+(defknown copy-pprint-dispatch
+ (&optional (or sb!pretty:pprint-dispatch-table null))
+ sb!pretty:pprint-dispatch-table
+ ())
+(defknown pprint-dispatch
+ (t &optional (or sb!pretty:pprint-dispatch-table null))
+ (values callable boolean)
+ ())
+(defknown (pprint-fill pprint-linear)
+ (streamlike t &optional t t)
+ null
+ ())
+(defknown pprint-tabular
+ (streamlike t &optional t t unsigned-byte)
+ null
+ ())
+(defknown pprint-indent
+ ((member :block :current) real &optional streamlike)
+ null
+ ())
+(defknown pprint-newline
+ ((member :linear :fill :miser :mandatory) &optional streamlike)
+ null
+ ())
+(defknown pprint-tab
+ ((member :line :section :line-relative :section-relative)
+ unsigned-byte unsigned-byte &optional streamlike)
+ null
+ ())
+(defknown set-pprint-dispatch
+ (type-specifier (or null callable)
+ &optional real sb!pretty:pprint-dispatch-table)
+ null
+ ())
+
;;; may return any type due to eof-value...
(defknown (read read-preserving-whitespace read-char-no-hang read-char)
(&optional streamlike t t t) t (explicit-check))
(write '`(lambda (,x)) :stream s :pretty t :readably t))
"`(LAMBDA (,X))"))
\f
+;;; SET-PPRINT-DISPATCH should accept function name arguments
+(defun ppd-function-name (s o)
+ (print (length o) s))
+(set-pprint-dispatch '(cons (eql frob)) 'ppd-function-name)
+(let ((s (with-output-to-string (s)
+ (pprint '(frob a b) s))))
+ (assert (position #\3 s)))
+\f
;;; success
(quit :unix-status 104)
;;; checkins which aren't released. (And occasionally for internal
;;; versions, especially for internal versions off the main CVS
;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.8.7.42"
+"0.8.7.43"
projects / sbcl.git / commitdiff