Changeset 15344


Ignore:
Timestamp:
Apr 26, 2012, 3:47:46 AM (7 years ago)
Author:
gb
Message:

(COPY-PPRINT-DISPATCH nil) creates a lightweight table (which provides
readonly access to the initial/internal dispatch table.) Calling
SET-PPRINT-DISPATCH on such a table creates a "heavyweight" table as
before.

The initial per-thread binding of *PRINT-PPRINT-DISPATCH* is a unique
dispatch table created by (COPY-PPRINT-DISPATCH NIL).

WITH-STANDARD-IO-SYNTAX binds *PRINT-PPRINT-DISPATCH* to a shared immutable
lightweight table; SET-PPRINT-DISPATCH refuses to allow this table to be
modified. (See the CLHS glossary entry for "initial pprint dispatch table.")

Fixes ticket:784 in the trunk.

Location:
trunk/source
Files:
3 edited

Legend:

Unmodified
Added
Removed
  • trunk/source/level-1/l1-io.lisp

    r15023 r15344  
    241241  "Controls default line length;  Must be a non-negative integer")
    242242
    243 (def-standard-initial-binding *PRINT-PPRINT-DISPATCH* nil) ; We have to support this.
    244243
    245244(defvar *xp-current-object* nil)  ; from xp
  • trunk/source/lib/macros.lisp

    r15306 r15344  
    16031603           (*print-lines* nil)
    16041604           (*print-miser-width* nil)
    1605            (*print-pprint-dispatch* nil)
     1605           (*print-pprint-dispatch* *standard-pprint-dispatch-table*)
    16061606           (*print-pretty* nil)
    16071607           (*print-radix* nil)
     
    16191619           (*print-simple-bit-vector* nil)
    16201620           (*print-string-length* nil))
     1621      (declare (special *standard-pprint-dispatch-table*))
    16211622       ,@decls
    16221623       ,@body)))
  • trunk/source/lib/pprint.lisp

    r15252 r15344  
    173173
    174174(cl:defstruct (pprint-dispatch-table (:conc-name nil) (:copier nil))
    175   (conses-with-cars (make-hash-table :test #'eq) :type hash-table)
    176   (structures (make-hash-table :test #'eq) :type (or null hash-table))
     175  (conses-with-cars (make-hash-table :test #'eq) :type (or null hash-table))
     176  (parent-table nil)
    177177  (others nil :type list)
    178178  (commit-hook nil))
    179179
    180 ;The list and the hash-tables contain entries of the
    181 ;following form.  When stored in the hash tables, the test entry is
    182 ;the number of entries in the OTHERS list that have a higher priority.
     180;;; We'd of course get finer-grained locking if each dispatch-table had
     181;;; its own lock, but we want to make creation of a pprint-dispatch-table
     182;;; as cheap as we can make it
     183(defstatic *pprint-dispatch-table-lock* (make-lock))
     184
     185
     186(defmethod print-object ((dispatch pprint-dispatch-table) stream)
     187  (print-unreadable-object (dispatch stream :type t :identity t)))
     188
     189(defstatic *standard-pprint-dispatch-table* nil) ;set below
     190
     191;;;The list and the hash-tables contain entries of the
     192;;;following form.  When stored in the hash tables, the test entry is
     193;;;the number of entries in the OTHERS list that have a higher priority.
    183194
    184195(defun make-entry (&key test fn full-spec)
    185196  (%istruct 'entry test fn full-spec))
    186197
     198
     199(defun copy-pprint-dispatch-table-conses-with-cars (table)
     200  (let* ((old (conses-with-cars table)))
     201    (when old
     202      (let* ((new (make-hash-table :test #'eq :size (max (hash-table-count old) 32))))
     203        (maphash (lambda (key value)
     204                   (setf (gethash key new)
     205                         (if (istruct-typep value 'entry)(copy-uvector value) value)))
     206                 old)
     207        new))))
     208
    187209(defun copy-pprint-dispatch (&optional (table *print-pprint-dispatch*))
    188   (let* ((table (if (null table)
    189                     *IPD*
    190                     (require-type table '(or nil pprint-dispatch-table))))
    191          (new-conses-with-cars
    192            (make-hash-table :test #'eq
    193              :size (max (hash-table-count (conses-with-cars table)) 32)))
    194          (new-structures NIL))
    195     (maphash #'(lambda (key value)
    196                  (setf (gethash key new-conses-with-cars)
    197                        (if (istruct-typep value 'entry)(copy-uvector value) value)))
    198              (conses-with-cars table))
     210  (if (null table)
    199211    (make-pprint-dispatch-table
    200       :conses-with-cars new-conses-with-cars
    201       :structures new-structures
    202       :others (copy-list (others table))
    203       :commit-hook (commit-hook table))))
     212     :conses-with-cars nil
     213     :others (copy-list (others *ipd*))
     214     :parent-table *ipd*
     215     :commit-hook (commit-hook *ipd*))
     216    (let* ((table (require-type table 'pprint-dispatch-table)))
     217      (with-lock-grabbed (*pprint-dispatch-table-lock*)
     218        (make-pprint-dispatch-table
     219         :others (copy-list (others table))
     220         :conses-with-cars (copy-pprint-dispatch-table-conses-with-cars table)
     221         :commit-hook (commit-hook table)
     222         :parent-table (parent-table table)
     223         :commit-hook (commit-hook table))))))
     224
    204225
    205226
     
    208229  (when (or (not (numberp priority)) (complexp priority))
    209230    (error "invalid PRIORITY argument ~A to SET-PPRINT-DISPATCH" priority))
    210   (set-pprint-dispatch+ type-specifier function priority table))
     231  (when (eq table *standard-pprint-dispatch-table*)
     232    (error "The standard pprint dispatch table must never be modified."))
     233  (with-lock-grabbed (*pprint-dispatch-table-lock*)
     234    (let* ((parent (parent-table table)))
     235      (when parent
     236        (setf (conses-with-cars table)
     237              (copy-pprint-dispatch-table-conses-with-cars parent)
     238              (others table) (copy-list (others parent))
     239              (parent-table table) nil))
     240      (set-pprint-dispatch+ type-specifier function priority table))))
     241
    211242
    212243(defun set-pprint-dispatch+ (type-specifier function priority table)
     
    230261      (cons-with-car
    231262       (let ((key (cadadr type-specifier)) ;(cons (member FOO))
    232              (cons-tbl (conses-with-cars table)))
     263             (cons-tbl (or (conses-with-cars table)
     264                           (setf (conses-with-cars table)
     265                                 (make-hash-table :test #'eq)))))
    233266        (cond ((null function) (remhash key cons-tbl))
    234267              (T (let ((num
     
    287320                               (- *print-level* *current-level*))
    288321                             nil nil)))
    289     (when (null table) (setq table *IPD*)) 
    290322    (let ((fn (get-printer object table)))
    291323      (values (or fn #'non-pretty-print) (not (null fn))))))
    292324
     325(defun get-printer-internal (object hash others)
     326  (let* (entry)
     327      (cond ((consp object)
     328             (setq entry (gethash (%car object) hash))
     329             (when (not entry)
     330               (setq entry (find object others :test #'fits))
     331               (if entry
     332                 (setq entry (entry-fn entry))))))
     333      (if (not entry)
     334        (setq entry (find object others :test #'fits))
     335        (if (istruct-typep entry 'entry)
     336          (let ((test (entry-test entry)))
     337            (when (numberp test)
     338              (do ((i test (1- i))
     339                   (l others (cdr l)))
     340                  ((zerop i))
     341                (when (fits object (car l)) (setq entry (car l)) (return nil)))))))
     342      (when entry
     343        (if (istruct-typep entry 'entry)(entry-fn entry) entry))))
     344
    293345(defun get-printer (object table)
    294   (when (null table)(setq table *IPD*))
    295   (let* (entry)
    296     (cond ((consp object)
    297            (setq entry (gethash (%car object) (conses-with-cars table)))
    298            (when (not entry)
    299              (setq entry (find object (others table) :test #'fits))
    300              (if entry
    301                (setq entry (entry-fn entry)))))
    302           (nil (setq entry (gethash (type-of object) (structures table)))))
    303     (if (not entry)
    304       (setq entry (find object (others table) :test #'fits))
    305       (if (istruct-typep entry 'entry)
    306         (let ((test (entry-test entry)))
    307           (when (numberp test)
    308             (do ((i test (1- i))
    309                  (l (others table) (cdr l)))
    310                 ((zerop i))
    311               (when (fits object (car l)) (setq entry (car l)) (return nil)))))))   
    312     (when entry
    313       (if (istruct-typep entry 'entry)(entry-fn entry) entry))))
     346  (let* ((parent (parent-table table)))
     347    (if parent
     348      (get-printer-internal object (conses-with-cars parent) (others parent))
     349      (with-lock-grabbed (*pprint-dispatch-table-lock*)
     350        (get-printer-internal object (conses-with-cars table) (others table))))))
    314351
    315352(defun fits (obj entry)
     
    20442081  (write-a-frob object stream level list-kludge))
    20452082
     2083(def-standard-initial-binding *PRINT-PPRINT-DISPATCH* (copy-pprint-dispatch nil)) ; We have to support this.
     2084
     2085(setq *standard-pprint-dispatch-table* (copy-pprint-dispatch nil))
     2086
    20462087(eval-when (:load-toplevel :execute)
    20472088  (setq *error-print-circle* t))
Note: See TracChangeset for help on using the changeset viewer.