From: Christophe Rhodes Date: Wed, 4 Feb 2004 21:16:23 +0000 (+0000) Subject: 0.8.7.43: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=8cd789d3fc2be931ee5c3d31f102616021f7f227;p=sbcl.git 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 --- diff --git a/build-order.lisp-expr b/build-order.lisp-expr index 4af8283..17e290b 100644 --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@ -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 diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 0e35b09..43ed578 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -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 diff --git a/src/code/host-pprint.lisp b/src/code/host-pprint.lisp new file mode 100644 index 0000000..cfdb9b2 --- /dev/null +++ b/src/code/host-pprint.lisp @@ -0,0 +1,24 @@ +;;;; 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 )). 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))) diff --git a/src/code/pprint.lisp b/src/code/pprint.lisp index 32df69b..b87e9ee 100644 --- a/src/code/pprint.lisp +++ b/src/code/pprint.lisp @@ -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 )). 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,38 +915,43 @@ (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)) diff --git a/src/compiler/fndb.lisp b/src/compiler/fndb.lisp index bd000be..e8b3b32 100644 --- a/src/compiler/fndb.lisp +++ b/src/compiler/fndb.lisp @@ -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)) diff --git a/tests/pprint.impure.lisp b/tests/pprint.impure.lisp index 32451be..a88e54a 100644 --- a/tests/pprint.impure.lisp +++ b/tests/pprint.impure.lisp @@ -136,5 +136,13 @@ (write '`(lambda (,x)) :stream s :pretty t :readably t)) "`(LAMBDA (,X))")) +;;; 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))) + ;;; success (quit :unix-status 104) diff --git a/version.lisp-expr b/version.lisp-expr index f1fec0a..7629d01 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; 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"