annotate lisp/emacs-lisp/cust-print.el @ 938:7a14bb062617

*** empty log message ***
author Jim Blandy <jimb@redhat.com>
date Wed, 05 Aug 1992 05:01:42 +0000
parents 213978acbc1e
children dcf780f7ae1b
Ignore whitespace changes - Everywhere: Within whitespace: At end of lines:
rev   line source
811
e694e0879463 *** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents: 807
diff changeset
1 ;; cust-print.el -- handles print-level and print-circle.
655
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
2
845
213978acbc1e entered into RCS
Eric S. Raymond <esr@snark.thyrsus.com>
parents: 811
diff changeset
3 ;; Copyright (C) 1992 Free Software Foundation, Inc.
213978acbc1e entered into RCS
Eric S. Raymond <esr@snark.thyrsus.com>
parents: 811
diff changeset
4
807
4f28bd14272c *** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents: 655
diff changeset
5 ;; Author: Daniel LaLiberte <liberte@cs.uiuc.edu>
4f28bd14272c *** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents: 655
diff changeset
6 ;; Version: 1.0
4f28bd14272c *** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents: 655
diff changeset
7 ;; Adapted-By: ESR
811
e694e0879463 *** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents: 807
diff changeset
8 ;; Keyword: extensions
655
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
9
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
10 ;; This file is part of GNU Emacs.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
11
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
12 ;; GNU Emacs is free software; you can redistribute it and/or modify
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
13 ;; it under the terms of the GNU General Public License as published by
807
4f28bd14272c *** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents: 655
diff changeset
14 ;; the Free Software Foundation; either version 2, or (at your option)
655
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
15 ;; any later version.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
16
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
17 ;; GNU Emacs is distributed in the hope that it will be useful,
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
18 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
19 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
20 ;; GNU General Public License for more details.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
21
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
22 ;; You should have received a copy of the GNU General Public License
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
23 ;; along with GNU Emacs; see the file COPYING. If not, write to
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
24 ;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
25
807
4f28bd14272c *** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents: 655
diff changeset
26 ;;; Commentary:
4f28bd14272c *** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents: 655
diff changeset
27
655
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
28 ;; This package provides a general print handler for prin1 and princ
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
29 ;; that supports print-level and print-circle, and by the way,
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
30 ;; print-length since the standard routines are being replaced. Also,
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
31 ;; to print custom types constructed from lists and vectors, use
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
32 ;; custom-print-list and custom-print-vector. See the documentation
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
33 ;; strings of these variables for more details.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
34
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
35 ;; If the results of your expressions contain circular references to
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
36 ;; other parts of the same structure, the standard Emacs print
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
37 ;; subroutines may fail to print with an untrappable error,
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
38 ;; "Apparently circular structure being printed". If you only use cdr
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
39 ;; circular lists (where cdrs of lists point back; what is the right
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
40 ;; term here?), you can limit the length of printing with
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
41 ;; print-length. But car circular lists and circular vectors generate
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
42 ;; the above mentioned untrappable error in Emacs version 18. Version
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
43 ;; 19 will support print-level, but it is often useful to get a better
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
44 ;; print representation of circular structures; the print-circle
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
45 ;; option may be used to print more concise representations.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
46
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
47 ;; There are two main ways to use this package. First, you may
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
48 ;; replace prin1, princ, and some subroutines that use them by calling
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
49 ;; install-custom-print-funcs so that any use of these functions in
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
50 ;; lisp code will be affected. Second, you could call the custom
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
51 ;; routines directly, thus only affecting the printing that requires
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
52 ;; them.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
53
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
54 ;; Note that subroutines which call print subroutines directly will not
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
55 ;; use the custom print functions. In particular, the evaluation
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
56 ;; functions like eval-region call the print subroutines directly.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
57 ;; Therefore, evaluating (aref circ-list 0), which calls error
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
58 ;; directly (because circ-list is not an array), will jump to the top
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
59 ;; level instead of printing the circular list.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
60
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
61 ;; Obviously the right way to implement this custom-print facility
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
62 ;; is in C. Please volunteer since I don't have the time or need.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
63
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
64 ;; Implementation design: we want to use the same list and vector
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
65 ;; processing algorithm for all versions of prin1 and princ, since how
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
66 ;; the processing is done depends on print-length, print-level, and
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
67 ;; print-circle. For circle printing, a preprocessing step is
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
68 ;; required before the final printing. Thanks to Jamie Zawinski
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
69 ;; for motivation and algorithms.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
70
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
71 ;;=========================================================
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
72 ;; export list:
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
73
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
74 ;; print-level
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
75 ;; print-circle
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
76
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
77 ;; custom-print-list
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
78 ;; custom-print-vector
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
79 ;; add-custom-print-list
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
80 ;; add-custom-print-vector
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
81
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
82 ;; install-custom-print-funcs
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
83 ;; uninstall-custom-print-funcs
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
84
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
85 ;; custom-prin1
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
86 ;; custom-princ
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
87 ;; custom-prin1-to-string
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
88 ;; custom-print
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
89 ;; custom-format
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
90 ;; custom-message
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
91 ;; custom-error
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
92
807
4f28bd14272c *** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents: 655
diff changeset
93 ;;; Code:
655
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
94
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
95 (provide 'custom-print)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
96 ;; Abbreviated package name: "CP"
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
97
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
98 ;;(defvar print-length nil
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
99 ;; "*Controls how many elements of a list, at each level, are printed.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
100 ;;This is defined by emacs.")
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
101
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
102 (defvar print-level nil
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
103 "*Controls how many levels deep a nested data object will print.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
104
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
105 If nil, printing proceeds recursively and may lead to
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
106 max-lisp-eval-depth being exceeded or an untrappable error may occur:
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
107 \"Apparently circular structure being printed.\" Also see
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
108 print-length and print-circle.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
109
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
110 If non-nil, components at levels equal to or greater than print-level
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
111 are printed simply as \"#\". The object to be printed is at level 0,
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
112 and if the object is a list or vector, its top-level components are at
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
113 level 1.")
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
114
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
115
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
116 (defvar print-circle nil
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
117 "*Controls the printing of recursive structures.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
118
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
119 If nil, printing proceeds recursively and may lead to
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
120 max-lisp-eval-depth being exceeded or an untrappable error may occur:
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
121 \"Apparently circular structure being printed.\" Also see
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
122 print-length and print-level.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
123
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
124 If non-nil, shared substructures anywhere in the structure are printed
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
125 with \"#n=\" before the first occurance (in the order of the print
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
126 representation) and \"#n#\" in place of each subsequent occurance,
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
127 where n is a positive decimal integer.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
128
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
129 Currently, there is no way to read this representation in Emacs.")
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
130
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
131
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
132 (defconst custom-print-list
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
133 nil
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
134 ;; e.g. '((floatp . float-to-string))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
135 "If non-nil, an alist for printing of custom list objects.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
136 Pairs are of the form (pred . converter). If the predicate is true
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
137 for an object, the converter is called with the object and should
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
138 return a string which will be printed with princ.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
139 Also see custom-print-vector.")
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
140
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
141 (defconst custom-print-vector
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
142 nil
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
143 "If non-nil, an alist for printing of custom vector objects.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
144 Pairs are of the form (pred . converter). If the predicate is true
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
145 for an object, the converter is called with the object and should
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
146 return a string which will be printed with princ.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
147 Also see custom-print-list.")
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
148
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
149
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
150 (defun add-custom-print-list (pred converter)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
151 "Add the pair, a PREDICATE and a CONVERTER, to custom-print-list.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
152 Any pair that has the same PREDICATE is first removed."
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
153 (setq custom-print-list (cons (cons pred converter)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
154 (delq (assq pred custom-print-list)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
155 custom-print-list))))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
156 ;; e.g. (add-custom-print-list 'floatp 'float-to-string)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
157
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
158
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
159 (defun add-custom-print-vector (pred converter)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
160 "Add the pair, a PREDICATE and a CONVERTER, to custom-print-vector.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
161 Any pair that has the same PREDICATE is first removed."
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
162 (setq custom-print-vector (cons (cons pred converter)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
163 (delq (assq pred custom-print-vector)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
164 custom-print-vector))))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
165
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
166
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
167 ;;====================================================
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
168 ;; Saving and restoring internal printing routines.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
169
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
170 (defun CP::set-function-cell (symbol-pair)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
171 (fset (car symbol-pair)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
172 (symbol-function (car (cdr symbol-pair)))))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
173
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
174
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
175 (if (not (fboundp 'CP::internal-prin1))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
176 (mapcar 'CP::set-function-cell
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
177 '((CP::internal-prin1 prin1)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
178 (CP::internal-princ princ)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
179 (CP::internal-print print)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
180 (CP::internal-prin1-to-string prin1-to-string)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
181 (CP::internal-format format)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
182 (CP::internal-message message)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
183 (CP::internal-error error))))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
184
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
185
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
186 (defun install-custom-print-funcs ()
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
187 "Replace print functions with general, customizable, lisp versions.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
188 The internal subroutines are saved away and may be recovered with
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
189 uninstall-custom-print-funcs."
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
190 (interactive)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
191 (mapcar 'CP::set-function-cell
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
192 '((prin1 custom-prin1)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
193 (princ custom-princ)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
194 (print custom-print)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
195 (prin1-to-string custom-prin1-to-string)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
196 (format custom-format)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
197 (message custom-message)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
198 (error custom-error)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
199 )))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
200
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
201 (defun uninstall-custom-print-funcs ()
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
202 "Reset print functions to their internal subroutines."
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
203 (interactive)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
204 (mapcar 'CP::set-function-cell
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
205 '((prin1 CP::internal-prin1)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
206 (princ CP::internal-princ)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
207 (print CP::internal-print)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
208 (prin1-to-string CP::internal-prin1-to-string)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
209 (format CP::internal-format)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
210 (message CP::internal-message)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
211 (error CP::internal-error)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
212 )))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
213
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
214
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
215 ;;===============================================================
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
216 ;; Lisp replacements for prin1 and princ and for subrs that use prin1
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
217 ;; (or princ) -- so far only the printing and formatting subrs.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
218
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
219 (defun custom-prin1 (object &optional stream)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
220 "Replacement for standard prin1 that uses the appropriate
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
221 printer depending on the values of print-level and print-circle (which see).
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
222
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
223 Output the printed representation of OBJECT, any Lisp object.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
224 Quoting characters are printed when needed to make output that `read'
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
225 can handle, whenever this is possible.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
226 Output stream is STREAM, or value of `standard-output' (which see)."
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
227 (CP::top-level object stream 'CP::internal-prin1))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
228
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
229
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
230 (defun custom-princ (object &optional stream)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
231 "Same as custom-prin1 except no quoting."
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
232 (CP::top-level object stream 'CP::internal-princ))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
233
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
234 (defun custom-prin1-to-string-func (c)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
235 "Stream function for custom-prin1-to-string."
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
236 (setq prin1-chars (cons c prin1-chars)))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
237
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
238 (defun custom-prin1-to-string (object)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
239 "Replacement for standard prin1-to-string."
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
240 (let ((prin1-chars nil))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
241 (custom-prin1 object 'custom-prin1-to-string-func)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
242 (concat (nreverse prin1-chars))))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
243
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
244
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
245 (defun custom-print (object &optional stream)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
246 "Replacement for standard print."
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
247 (CP::internal-princ "\n")
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
248 (custom-prin1 object stream)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
249 (CP::internal-princ "\n"))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
250
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
251
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
252 (defun custom-format (fmt &rest args)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
253 "Replacement for standard format.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
254
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
255 Calls format after first making strings for list or vector args.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
256 The format specification for such args should be %s in any case, so a
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
257 string argument will also work. The string is generated with
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
258 custom-prin1-to-string, which quotes quotable characters."
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
259 (apply 'CP::internal-format fmt
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
260 (mapcar (function (lambda (arg)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
261 (if (or (listp arg) (vectorp arg))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
262 (custom-prin1-to-string arg)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
263 arg)))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
264 args)))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
265
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
266
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
267
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
268 (defun custom-message (fmt &rest args)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
269 "Replacement for standard message that works like custom-format."
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
270 ;; It doesnt work to princ the result of custom-format
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
271 ;; because the echo area requires special handling
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
272 ;; to avoid duplicating the output. CP::internal-message does it right.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
273 ;; (CP::internal-princ (apply 'custom-format fmt args))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
274 (apply 'CP::internal-message fmt
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
275 (mapcar (function (lambda (arg)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
276 (if (or (listp arg) (vectorp arg))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
277 (custom-prin1-to-string arg)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
278 arg)))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
279 args)))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
280
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
281
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
282 (defun custom-error (fmt &rest args)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
283 "Replacement for standard error that uses custom-format"
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
284 (signal 'error (list (apply 'custom-format fmt args))))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
285
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
286
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
287 ;;=========================================
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
288 ;; Support for custom prin1 and princ
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
289
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
290 (defun CP::top-level (object stream internal-printer)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
291 "Set up for printing."
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
292 (let ((standard-output (or stream standard-output))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
293 (circle-table (and print-circle (CP::preprocess-circle-tree object)))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
294 (level (or print-level -1))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
295 )
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
296
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
297 (fset 'CP::internal-printer internal-printer)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
298 (fset 'CP::low-level-prin
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
299 (cond
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
300 ((or custom-print-list
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
301 custom-print-vector
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
302 print-level ; comment out for version 19
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
303 )
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
304 'CP::custom-object)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
305 (circle-table
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
306 'CP::object)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
307 (t 'CP::internal-printer)))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
308 (fset 'CP::prin (if circle-table 'CP::circular 'CP::low-level-prin))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
309
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
310 (CP::prin object)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
311 object))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
312
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
313
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
314 (defun CP::object (object)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
315 "Test object type and print accordingly."
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
316 ;; Could be called as either CP::low-level-prin or CP::prin.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
317 (cond
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
318 ((null object) (CP::internal-printer object))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
319 ((consp object) (CP::list object))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
320 ((vectorp object) (CP::vector object))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
321 ;; All other types, just print.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
322 (t (CP::internal-printer object))))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
323
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
324
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
325 (defun CP::custom-object (object)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
326 "Test object type and print accordingly."
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
327 ;; Could be called as either CP::low-level-prin or CP::prin.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
328 (cond
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
329 ((null object) (CP::internal-printer object))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
330
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
331 ((consp object)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
332 (or (and custom-print-list
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
333 (CP::custom-object1 object custom-print-list))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
334 (CP::list object)))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
335
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
336 ((vectorp object)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
337 (or (and custom-print-vector
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
338 (CP::custom-object1 object custom-print-vector))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
339 (CP::vector object)))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
340
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
341 ;; All other types, just print.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
342 (t (CP::internal-printer object))))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
343
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
344
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
345 (defun CP::custom-object1 (object alist)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
346 "Helper for CP::custom-object.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
347 Print the custom OBJECT using the custom type ALIST.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
348 For the first predicate that matches the object, the corresponding
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
349 converter is evaluated with the object and the string that results is
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
350 printed with princ. Return nil if no predicte matches the object."
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
351 (while (and alist (not (funcall (car (car alist)) object)))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
352 (setq alist (cdr alist)))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
353 ;; If alist is not null, then something matched.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
354 (if alist
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
355 (CP::internal-princ
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
356 (funcall (cdr (car alist)) object) ; returns string
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
357 )))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
358
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
359
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
360 (defun CP::circular (object)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
361 "Printer for prin1 and princ that handles circular structures.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
362 If OBJECT appears multiply, and has not yet been printed,
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
363 prefix with label; if it has been printed, use #n# instead.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
364 Otherwise, print normally."
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
365 (let ((tag (assq object circle-table)))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
366 (if tag
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
367 (let ((id (cdr tag)))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
368 (if (> id 0)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
369 (progn
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
370 ;; Already printed, so just print id.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
371 (CP::internal-princ "#")
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
372 (CP::internal-princ id)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
373 (CP::internal-princ "#"))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
374 ;; Not printed yet, so label with id and print object.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
375 (setcdr tag (- id)) ; mark it as printed
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
376 (CP::internal-princ "#")
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
377 (CP::internal-princ (- id))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
378 (CP::internal-princ "=")
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
379 (CP::low-level-prin object)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
380 ))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
381 ;; Not repeated in structure.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
382 (CP::low-level-prin object))))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
383
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
384
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
385 ;;================================================
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
386 ;; List and vector processing for print functions.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
387
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
388 (defun CP::list (list)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
389 "Print a list using print-length, print-level, and print-circle."
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
390 (if (= level 0)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
391 (CP::internal-princ "#")
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
392 (let ((level (1- level)))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
393 (CP::internal-princ "(")
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
394 (let ((length (or print-length 0)))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
395
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
396 ;; Print the first element always (even if length = 0).
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
397 (CP::prin (car list))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
398 (setq list (cdr list))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
399 (if list (CP::internal-princ " "))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
400 (setq length (1- length))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
401
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
402 ;; Print the rest of the elements.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
403 (while (and list (/= 0 length))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
404 (if (and (listp list)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
405 (not (assq list circle-table)))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
406 (progn
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
407 (CP::prin (car list))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
408 (setq list (cdr list)))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
409
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
410 ;; cdr is not a list, or it is in circle-table.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
411 (CP::internal-princ ". ")
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
412 (CP::prin list)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
413 (setq list nil))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
414
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
415 (setq length (1- length))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
416 (if list (CP::internal-princ " ")))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
417
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
418 (if (and list (= length 0)) (CP::internal-princ "..."))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
419 (CP::internal-princ ")"))))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
420 list)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
421
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
422
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
423 (defun CP::vector (vector)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
424 "Print a vector using print-length, print-level, and print-circle."
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
425 (if (= level 0)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
426 (CP::internal-princ "#")
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
427 (let ((level (1- level))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
428 (i 0)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
429 (len (length vector)))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
430 (CP::internal-princ "[")
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
431
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
432 (if print-length
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
433 (setq len (min print-length len)))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
434 ;; Print the elements
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
435 (while (< i len)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
436 (CP::prin (aref vector i))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
437 (setq i (1+ i))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
438 (if (< i (length vector)) (CP::internal-princ " ")))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
439
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
440 (if (< i (length vector)) (CP::internal-princ "..."))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
441 (CP::internal-princ "]")
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
442 ))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
443 vector)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
444
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
445
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
446 ;;==================================
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
447 ;; Circular structure preprocessing
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
448
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
449 (defun CP::preprocess-circle-tree (object)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
450 ;; Fill up the table.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
451 (let (;; Table of tags for each object in an object to be printed.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
452 ;; A tag is of the form:
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
453 ;; ( <object> <nil-t-or-id-number> )
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
454 ;; The id-number is generated after the entire table has been computed.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
455 ;; During walk through, the real circle-table lives in the cdr so we
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
456 ;; can use setcdr to add new elements instead of having to setq the
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
457 ;; variable sometimes (poor man's locf).
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
458 (circle-table (list nil)))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
459 (CP::walk-circle-tree object)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
460
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
461 ;; Reverse table so it is in the order that the objects will be printed.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
462 ;; This pass could be avoided if we always added to the end of the
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
463 ;; table with setcdr in walk-circle-tree.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
464 (setcdr circle-table (nreverse (cdr circle-table)))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
465
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
466 ;; Walk through the table, assigning id-numbers to those
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
467 ;; objects which will be printed using #N= syntax. Delete those
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
468 ;; objects which will be printed only once (to speed up assq later).
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
469 (let ((rest circle-table)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
470 (id -1))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
471 (while (cdr rest)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
472 (let ((tag (car (cdr rest))))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
473 (cond ((cdr tag)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
474 (setcdr tag id)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
475 (setq id (1- id))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
476 (setq rest (cdr rest)))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
477 ;; Else delete this object.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
478 (t (setcdr rest (cdr (cdr rest))))))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
479 ))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
480 ;; Drop the car.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
481 (cdr circle-table)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
482 ))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
483
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
484
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
485
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
486 (defun CP::walk-circle-tree (object)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
487 (let (read-equivalent-p tag)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
488 (while object
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
489 (setq read-equivalent-p (or (numberp object) (symbolp object))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
490 tag (and (not read-equivalent-p)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
491 (assq object (cdr circle-table))))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
492 (cond (tag
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
493 ;; Seen this object already, so note that.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
494 (setcdr tag t))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
495
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
496 ((not read-equivalent-p)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
497 ;; Add a tag for this object.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
498 (setcdr circle-table
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
499 (cons (list object)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
500 (cdr circle-table)))))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
501 (setq object
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
502 (cond
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
503 (tag ;; No need to descend since we have already.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
504 nil)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
505
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
506 ((consp object)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
507 ;; Walk the car of the list recursively.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
508 (CP::walk-circle-tree (car object))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
509 ;; But walk the cdr with the above while loop
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
510 ;; to avoid problems with max-lisp-eval-depth.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
511 ;; And it should be faster than recursion.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
512 (cdr object))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
513
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
514 ((vectorp object)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
515 ;; Walk the vector.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
516 (let ((i (length object))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
517 (j 0))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
518 (while (< j i)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
519 (CP::walk-circle-tree (aref object j))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
520 (setq j (1+ j))))))))))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
521
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
522
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
523
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
524 ;;=======================================
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
525
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
526 (quote
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
527 examples
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
528
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
529 (progn
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
530 ;; Create some circular structures.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
531 (setq circ-sym (let ((x (make-symbol "FOO"))) (list x x)))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
532 (setq circ-list (list 'a 'b (vector 1 2 3 4) 'd 'e 'f))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
533 (setcar (nthcdr 3 circ-list) circ-list)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
534 (aset (nth 2 circ-list) 2 circ-list)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
535 (setq dotted-circ-list (list 'a 'b 'c))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
536 (setcdr (cdr (cdr dotted-circ-list)) dotted-circ-list)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
537 (setq circ-vector (vector 1 2 3 4 (list 'a 'b 'c 'd) 6 7))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
538 (aset circ-vector 5 (make-symbol "-gensym-"))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
539 (setcar (cdr (aref circ-vector 4)) (aref circ-vector 5))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
540 nil)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
541
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
542 (install-custom-print-funcs)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
543 ;; (setq print-circle t)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
544
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
545 (let ((print-circle t))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
546 (or (equal (prin1-to-string circ-list) "#1=(a b [1 2 #1# 4] #1# e f)")
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
547 (error "circular object with array printing")))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
548
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
549 (let ((print-circle t))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
550 (or (equal (prin1-to-string dotted-circ-list) "#1=(a b c . #1#)")
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
551 (error "circular object with array printing")))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
552
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
553 (let* ((print-circle t)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
554 (x (list 'p 'q))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
555 (y (list (list 'a 'b) x 'foo x)))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
556 (setcdr (cdr (cdr (cdr y))) (cdr y))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
557 (or (equal (prin1-to-string y) "((a b) . #1=(#2=(p q) foo #2# . #1#))"
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
558 )
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
559 (error "circular list example from CL manual")))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
560
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
561 ;; There's no special handling of uninterned symbols in custom-print.
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
562 (let ((print-circle nil))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
563 (or (equal (prin1-to-string circ-sym) "(#:FOO #:FOO)")
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
564 (error "uninterned symbols in list")))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
565 (let ((print-circle t))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
566 (or (equal (prin1-to-string circ-sym) "(#1=FOO #1#)")
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
567 (error "circular uninterned symbols in list")))
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
568
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
569 (uninstall-custom-print-funcs)
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
570 )
02591d9e7ad3 Initial revision
Eric S. Raymond <esr@snark.thyrsus.com>
parents:
diff changeset
571
811
e694e0879463 *** empty log message ***
Eric S. Raymond <esr@snark.thyrsus.com>
parents: 807
diff changeset
572 ;;; cust-print.el ends here