Commit 8cd789d3 authored by Christophe Rhodes's avatar Christophe Rhodes
Browse files

0.8.7.43: 

	Allow SET-PPRINT-DISPATCH to take symbols as arguments
	... possibly violate ANSI by immediate coercion to function
	... move things around so that I can add the pprinting
		functions to fndb (new host-pprint file)
	... also delete unused WHITESPACE-CHAR-P
parent e14f0127

build-order.lisp-expr

+1 −0
Original line number Diff line number Diff line
@@ -413,6 +413,7 @@ 
 ("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

package-data-list.lisp-expr

+1 −1
Original line number Diff line number Diff line
@@ -880,7 +880,6 @@ retained, possibly temporariliy, because it might be used internally." 
             "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"
@@ -1710,6 +1709,7 @@ definitely not guaranteed to be present in later versions of SBCL." 
    :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

src/code/host-pprint.lisp

0 → 100644
+24 −0
Original line number Diff line number Diff line 
;;;; 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)))

src/code/pprint.lisp

+32 −38
Original line number Diff line number Diff line
@@ -811,17 +811,6 @@ 
	    (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)
@@ -926,12 +915,17 @@ 


(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

      ;; 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))
@@ -957,7 +951,7 @@ 
		      (setf (cdr prev) (cons entry next))

		      (setf list (cons entry next)))

		  (return)))

	    (setf (pprint-dispatch-table-entries table) list)))

	      (setf (pprint-dispatch-table-entries table) list))))

      (if (cons-type-specifier-p type)

	  (remhash (second (second type))

		   (pprint-dispatch-table-cons-entries table))

src/compiler/fndb.lisp

+35 −0
Original line number Diff line number Diff line
@@ -962,6 +962,41 @@ 
  (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))