diff options
| author | Richard M. Stallman | 1992-10-07 09:09:19 +0000 |
|---|---|---|
| committer | Richard M. Stallman | 1992-10-07 09:09:19 +0000 |
| commit | fb252f97f1875b6e06ff5bf95b088557caf6cdcd (patch) | |
| tree | 6a2a0e95e5b5768980eb1d77e36ac12be78220cc | |
| parent | 72b2181785d12fe97e4518bb62c4fe034c49915c (diff) | |
| download | emacs-fb252f97f1875b6e06ff5bf95b088557caf6cdcd.tar.gz emacs-fb252f97f1875b6e06ff5bf95b088557caf6cdcd.zip | |
CP:: changed to cust-print- in all names.
Lots of doc fixes.
| -rw-r--r-- | lisp/emacs-lisp/cust-print.el | 261 |
1 files changed, 130 insertions, 131 deletions
diff --git a/lisp/emacs-lisp/cust-print.el b/lisp/emacs-lisp/cust-print.el index 2dc18d43f93..6ce301cd3d5 100644 --- a/lisp/emacs-lisp/cust-print.el +++ b/lisp/emacs-lisp/cust-print.el | |||
| @@ -93,7 +93,6 @@ | |||
| 93 | ;;; Code: | 93 | ;;; Code: |
| 94 | 94 | ||
| 95 | (provide 'custom-print) | 95 | (provide 'custom-print) |
| 96 | ;; Abbreviated package name: "CP" | ||
| 97 | 96 | ||
| 98 | ;;(defvar print-length nil | 97 | ;;(defvar print-length nil |
| 99 | ;; "*Controls how many elements of a list, at each level, are printed. | 98 | ;; "*Controls how many elements of a list, at each level, are printed. |
| @@ -104,10 +103,10 @@ | |||
| 104 | 103 | ||
| 105 | If nil, printing proceeds recursively and may lead to | 104 | If nil, printing proceeds recursively and may lead to |
| 106 | max-lisp-eval-depth being exceeded or an untrappable error may occur: | 105 | max-lisp-eval-depth being exceeded or an untrappable error may occur: |
| 107 | \"Apparently circular structure being printed.\" Also see | 106 | `Apparently circular structure being printed.' |
| 108 | print-length and print-circle. | 107 | Also see `print-length' and `print-circle'. |
| 109 | 108 | ||
| 110 | If non-nil, components at levels equal to or greater than print-level | 109 | If non-nil, components at levels equal to or greater than `print-level' |
| 111 | are printed simply as \"#\". The object to be printed is at level 0, | 110 | are printed simply as \"#\". The object to be printed is at level 0, |
| 112 | and if the object is a list or vector, its top-level components are at | 111 | and if the object is a list or vector, its top-level components are at |
| 113 | level 1.") | 112 | level 1.") |
| @@ -117,14 +116,14 @@ level 1.") | |||
| 117 | "*Controls the printing of recursive structures. | 116 | "*Controls the printing of recursive structures. |
| 118 | 117 | ||
| 119 | If nil, printing proceeds recursively and may lead to | 118 | If nil, printing proceeds recursively and may lead to |
| 120 | max-lisp-eval-depth being exceeded or an untrappable error may occur: | 119 | `max-lisp-eval-depth' being exceeded or an untrappable error may occur: |
| 121 | \"Apparently circular structure being printed.\" Also see | 120 | \"Apparently circular structure being printed.\" Also see |
| 122 | print-length and print-level. | 121 | `print-length' and `print-level'. |
| 123 | 122 | ||
| 124 | If non-nil, shared substructures anywhere in the structure are printed | 123 | If non-nil, shared substructures anywhere in the structure are printed |
| 125 | with \"#n=\" before the first occurance (in the order of the print | 124 | with `#N=' before the first occurance (in the order of the print |
| 126 | representation) and \"#n#\" in place of each subsequent occurance, | 125 | representation) and `#N#' in place of each subsequent occurance, |
| 127 | where n is a positive decimal integer. | 126 | where N is a positive decimal integer. |
| 128 | 127 | ||
| 129 | Currently, there is no way to read this representation in Emacs.") | 128 | Currently, there is no way to read this representation in Emacs.") |
| 130 | 129 | ||
| @@ -132,23 +131,23 @@ Currently, there is no way to read this representation in Emacs.") | |||
| 132 | (defconst custom-print-list | 131 | (defconst custom-print-list |
| 133 | nil | 132 | nil |
| 134 | ;; e.g. '((floatp . float-to-string)) | 133 | ;; e.g. '((floatp . float-to-string)) |
| 135 | "If non-nil, an alist for printing of custom list objects. | 134 | "An alist for custom printing of lists. |
| 136 | Pairs are of the form (pred . converter). If the predicate is true | 135 | Pairs are of the form (PRED . CONVERTER). If PREDICATE is true |
| 137 | for an object, the converter is called with the object and should | 136 | for an object, then CONVERTER is called with the object and should |
| 138 | return a string which will be printed with princ. | 137 | return a string to be printed with `princ'. |
| 139 | Also see custom-print-vector.") | 138 | Also see `custom-print-vector'.") |
| 140 | 139 | ||
| 141 | (defconst custom-print-vector | 140 | (defconst custom-print-vector |
| 142 | nil | 141 | nil |
| 143 | "If non-nil, an alist for printing of custom vector objects. | 142 | "An alist for custom printing of vectors. |
| 144 | Pairs are of the form (pred . converter). If the predicate is true | 143 | Pairs are of the form (PRED . CONVERTER). If PREDICATE is true |
| 145 | for an object, the converter is called with the object and should | 144 | for an object, then CONVERTER is called with the object and should |
| 146 | return a string which will be printed with princ. | 145 | return a string to be printed with `princ'. |
| 147 | Also see custom-print-list.") | 146 | Also see `custom-print-list'.") |
| 148 | 147 | ||
| 149 | 148 | ||
| 150 | (defun add-custom-print-list (pred converter) | 149 | (defun add-custom-print-list (pred converter) |
| 151 | "Add the pair, a PREDICATE and a CONVERTER, to custom-print-list. | 150 | "Add a pair of PREDICATE and CONVERTER to `custom-print-list'. |
| 152 | Any pair that has the same PREDICATE is first removed." | 151 | Any pair that has the same PREDICATE is first removed." |
| 153 | (setq custom-print-list (cons (cons pred converter) | 152 | (setq custom-print-list (cons (cons pred converter) |
| 154 | (delq (assq pred custom-print-list) | 153 | (delq (assq pred custom-print-list) |
| @@ -157,7 +156,7 @@ Any pair that has the same PREDICATE is first removed." | |||
| 157 | 156 | ||
| 158 | 157 | ||
| 159 | (defun add-custom-print-vector (pred converter) | 158 | (defun add-custom-print-vector (pred converter) |
| 160 | "Add the pair, a PREDICATE and a CONVERTER, to custom-print-vector. | 159 | "Add a pair of PREDICATE and CONVERTER to `custom-print-vector'. |
| 161 | Any pair that has the same PREDICATE is first removed." | 160 | Any pair that has the same PREDICATE is first removed." |
| 162 | (setq custom-print-vector (cons (cons pred converter) | 161 | (setq custom-print-vector (cons (cons pred converter) |
| 163 | (delq (assq pred custom-print-vector) | 162 | (delq (assq pred custom-print-vector) |
| @@ -167,28 +166,28 @@ Any pair that has the same PREDICATE is first removed." | |||
| 167 | ;;==================================================== | 166 | ;;==================================================== |
| 168 | ;; Saving and restoring internal printing routines. | 167 | ;; Saving and restoring internal printing routines. |
| 169 | 168 | ||
| 170 | (defun CP::set-function-cell (symbol-pair) | 169 | (defun cust-print-set-function-cell (symbol-pair) |
| 171 | (fset (car symbol-pair) | 170 | (fset (car symbol-pair) |
| 172 | (symbol-function (car (cdr symbol-pair))))) | 171 | (symbol-function (car (cdr symbol-pair))))) |
| 173 | 172 | ||
| 174 | 173 | ||
| 175 | (if (not (fboundp 'CP::internal-prin1)) | 174 | (if (not (fboundp 'cust-print-internal-prin1)) |
| 176 | (mapcar 'CP::set-function-cell | 175 | (mapcar 'cust-print-set-function-cell |
| 177 | '((CP::internal-prin1 prin1) | 176 | '((cust-print-internal-prin1 prin1) |
| 178 | (CP::internal-princ princ) | 177 | (cust-print-internal-princ princ) |
| 179 | (CP::internal-print print) | 178 | (cust-print-internal-print print) |
| 180 | (CP::internal-prin1-to-string prin1-to-string) | 179 | (cust-print-internal-prin1-to-string prin1-to-string) |
| 181 | (CP::internal-format format) | 180 | (cust-print-internal-format format) |
| 182 | (CP::internal-message message) | 181 | (cust-print-internal-message message) |
| 183 | (CP::internal-error error)))) | 182 | (cust-print-internal-error error)))) |
| 184 | 183 | ||
| 185 | 184 | ||
| 186 | (defun install-custom-print-funcs () | 185 | (defun install-custom-print-funcs () |
| 187 | "Replace print functions with general, customizable, lisp versions. | 186 | "Replace print functions with general, customizable, Lisp versions. |
| 188 | The internal subroutines are saved away and may be recovered with | 187 | The internal subroutines are saved away, and you can reinstall them |
| 189 | uninstall-custom-print-funcs." | 188 | by running `uninstall-custom-print-funcs'." |
| 190 | (interactive) | 189 | (interactive) |
| 191 | (mapcar 'CP::set-function-cell | 190 | (mapcar 'cust-print-set-function-cell |
| 192 | '((prin1 custom-prin1) | 191 | '((prin1 custom-prin1) |
| 193 | (princ custom-princ) | 192 | (princ custom-princ) |
| 194 | (print custom-print) | 193 | (print custom-print) |
| @@ -201,14 +200,14 @@ uninstall-custom-print-funcs." | |||
| 201 | (defun uninstall-custom-print-funcs () | 200 | (defun uninstall-custom-print-funcs () |
| 202 | "Reset print functions to their internal subroutines." | 201 | "Reset print functions to their internal subroutines." |
| 203 | (interactive) | 202 | (interactive) |
| 204 | (mapcar 'CP::set-function-cell | 203 | (mapcar 'cust-print-set-function-cell |
| 205 | '((prin1 CP::internal-prin1) | 204 | '((prin1 cust-print-internal-prin1) |
| 206 | (princ CP::internal-princ) | 205 | (princ cust-print-internal-princ) |
| 207 | (print CP::internal-print) | 206 | (print cust-print-internal-print) |
| 208 | (prin1-to-string CP::internal-prin1-to-string) | 207 | (prin1-to-string cust-print-internal-prin1-to-string) |
| 209 | (format CP::internal-format) | 208 | (format cust-print-internal-format) |
| 210 | (message CP::internal-message) | 209 | (message cust-print-internal-message) |
| 211 | (error CP::internal-error) | 210 | (error cust-print-internal-error) |
| 212 | ))) | 211 | ))) |
| 213 | 212 | ||
| 214 | 213 | ||
| @@ -217,47 +216,47 @@ uninstall-custom-print-funcs." | |||
| 217 | ;; (or princ) -- so far only the printing and formatting subrs. | 216 | ;; (or princ) -- so far only the printing and formatting subrs. |
| 218 | 217 | ||
| 219 | (defun custom-prin1 (object &optional stream) | 218 | (defun custom-prin1 (object &optional stream) |
| 220 | "Replacement for standard prin1. | 219 | "Replacement for standard `prin1'. |
| 221 | Uses the appropriate printer depending on the values of print-level | 220 | Uses the appropriate printer depending on the values of `print-level' |
| 222 | and print-circle (which see). | 221 | and `print-circle' (which see). |
| 223 | 222 | ||
| 224 | Output the printed representation of OBJECT, any Lisp object. | 223 | Output the printed representation of OBJECT, any Lisp object. |
| 225 | Quoting characters are printed when needed to make output that `read' | 224 | Quoting characters are printed when needed to make output that `read' |
| 226 | can handle, whenever this is possible. | 225 | can handle, whenever this is possible. |
| 227 | Output stream is STREAM, or value of `standard-output' (which see)." | 226 | Output stream is STREAM, or value of `standard-output' (which see)." |
| 228 | (CP::top-level object stream 'CP::internal-prin1)) | 227 | (cust-print-top-level object stream 'cust-print-internal-prin1)) |
| 229 | 228 | ||
| 230 | 229 | ||
| 231 | (defun custom-princ (object &optional stream) | 230 | (defun custom-princ (object &optional stream) |
| 232 | "Same as custom-prin1 except no quoting." | 231 | "Same as `custom-prin1' except no quoting." |
| 233 | (CP::top-level object stream 'CP::internal-princ)) | 232 | (cust-print-top-level object stream 'cust-print-internal-princ)) |
| 234 | 233 | ||
| 235 | (defun custom-prin1-to-string-func (c) | 234 | (defun custom-prin1-to-string-func (c) |
| 236 | "Stream function for custom-prin1-to-string." | 235 | "Stream function for `custom-prin1-to-string'." |
| 237 | (setq prin1-chars (cons c prin1-chars))) | 236 | (setq prin1-chars (cons c prin1-chars))) |
| 238 | 237 | ||
| 239 | (defun custom-prin1-to-string (object) | 238 | (defun custom-prin1-to-string (object) |
| 240 | "Replacement for standard prin1-to-string." | 239 | "Replacement for standard `prin1-to-string'." |
| 241 | (let ((prin1-chars nil)) | 240 | (let ((prin1-chars nil)) |
| 242 | (custom-prin1 object 'custom-prin1-to-string-func) | 241 | (custom-prin1 object 'custom-prin1-to-string-func) |
| 243 | (concat (nreverse prin1-chars)))) | 242 | (concat (nreverse prin1-chars)))) |
| 244 | 243 | ||
| 245 | 244 | ||
| 246 | (defun custom-print (object &optional stream) | 245 | (defun custom-print (object &optional stream) |
| 247 | "Replacement for standard print." | 246 | "Replacement for standard `print'." |
| 248 | (CP::internal-princ "\n") | 247 | (cust-print-internal-princ "\n") |
| 249 | (custom-prin1 object stream) | 248 | (custom-prin1 object stream) |
| 250 | (CP::internal-princ "\n")) | 249 | (cust-print-internal-princ "\n")) |
| 251 | 250 | ||
| 252 | 251 | ||
| 253 | (defun custom-format (fmt &rest args) | 252 | (defun custom-format (fmt &rest args) |
| 254 | "Replacement for standard format. | 253 | "Replacement for standard `format'. |
| 255 | 254 | ||
| 256 | Calls format after first making strings for list or vector args. | 255 | Calls format after first making strings for list or vector args. |
| 257 | The format specification for such args should be %s in any case, so a | 256 | The format specification for such args should be `%s' in any case, so a |
| 258 | string argument will also work. The string is generated with | 257 | string argument will also work. The string is generated with |
| 259 | custom-prin1-to-string, which quotes quotable characters." | 258 | `custom-prin1-to-string', which quotes quotable characters." |
| 260 | (apply 'CP::internal-format fmt | 259 | (apply 'cust-print-internal-format fmt |
| 261 | (mapcar (function (lambda (arg) | 260 | (mapcar (function (lambda (arg) |
| 262 | (if (or (listp arg) (vectorp arg)) | 261 | (if (or (listp arg) (vectorp arg)) |
| 263 | (custom-prin1-to-string arg) | 262 | (custom-prin1-to-string arg) |
| @@ -267,12 +266,12 @@ custom-prin1-to-string, which quotes quotable characters." | |||
| 267 | 266 | ||
| 268 | 267 | ||
| 269 | (defun custom-message (fmt &rest args) | 268 | (defun custom-message (fmt &rest args) |
| 270 | "Replacement for standard message that works like custom-format." | 269 | "Replacement for standard `message' that works like `custom-format'." |
| 271 | ;; It doesnt work to princ the result of custom-format | 270 | ;; It doesnt work to princ the result of custom-format |
| 272 | ;; because the echo area requires special handling | 271 | ;; because the echo area requires special handling |
| 273 | ;; to avoid duplicating the output. CP::internal-message does it right. | 272 | ;; to avoid duplicating the output. cust-print-internal-message does it right. |
| 274 | ;; (CP::internal-princ (apply 'custom-format fmt args)) | 273 | ;; (cust-print-internal-princ (apply 'custom-format fmt args)) |
| 275 | (apply 'CP::internal-message fmt | 274 | (apply 'cust-print-internal-message fmt |
| 276 | (mapcar (function (lambda (arg) | 275 | (mapcar (function (lambda (arg) |
| 277 | (if (or (listp arg) (vectorp arg)) | 276 | (if (or (listp arg) (vectorp arg)) |
| 278 | (custom-prin1-to-string arg) | 277 | (custom-prin1-to-string arg) |
| @@ -281,87 +280,87 @@ custom-prin1-to-string, which quotes quotable characters." | |||
| 281 | 280 | ||
| 282 | 281 | ||
| 283 | (defun custom-error (fmt &rest args) | 282 | (defun custom-error (fmt &rest args) |
| 284 | "Replacement for standard error that uses custom-format" | 283 | "Replacement for standard `error' that uses `custom-format'" |
| 285 | (signal 'error (list (apply 'custom-format fmt args)))) | 284 | (signal 'error (list (apply 'custom-format fmt args)))) |
| 286 | 285 | ||
| 287 | 286 | ||
| 288 | ;;========================================= | 287 | ;;========================================= |
| 289 | ;; Support for custom prin1 and princ | 288 | ;; Support for custom prin1 and princ |
| 290 | 289 | ||
| 291 | (defun CP::top-level (object stream internal-printer) | 290 | (defun cust-print-top-level (object stream internal-printer) |
| 292 | "Set up for printing." | 291 | "Set up for printing." |
| 293 | (let ((standard-output (or stream standard-output)) | 292 | (let ((standard-output (or stream standard-output)) |
| 294 | (circle-table (and print-circle (CP::preprocess-circle-tree object))) | 293 | (circle-table (and print-circle (cust-print-preprocess-circle-tree object))) |
| 295 | (level (or print-level -1)) | 294 | (level (or print-level -1)) |
| 296 | ) | 295 | ) |
| 297 | 296 | ||
| 298 | (fset 'CP::internal-printer internal-printer) | 297 | (fset 'cust-print-internal-printer internal-printer) |
| 299 | (fset 'CP::low-level-prin | 298 | (fset 'cust-print-low-level-prin |
| 300 | (cond | 299 | (cond |
| 301 | ((or custom-print-list | 300 | ((or custom-print-list |
| 302 | custom-print-vector | 301 | custom-print-vector |
| 303 | print-level ; comment out for version 19 | 302 | print-level ; comment out for version 19 |
| 304 | ) | 303 | ) |
| 305 | 'CP::custom-object) | 304 | 'cust-print-custom-object) |
| 306 | (circle-table | 305 | (circle-table |
| 307 | 'CP::object) | 306 | 'cust-print-object) |
| 308 | (t 'CP::internal-printer))) | 307 | (t 'cust-print-internal-printer))) |
| 309 | (fset 'CP::prin (if circle-table 'CP::circular 'CP::low-level-prin)) | 308 | (fset 'cust-print-prin (if circle-table 'cust-print-circular 'cust-print-low-level-prin)) |
| 310 | 309 | ||
| 311 | (CP::prin object) | 310 | (cust-print-prin object) |
| 312 | object)) | 311 | object)) |
| 313 | 312 | ||
| 314 | 313 | ||
| 315 | (defun CP::object (object) | 314 | ;; Test object type and print accordingly. |
| 316 | "Test object type and print accordingly." | 315 | (defun cust-print-object (object) |
| 317 | ;; Could be called as either CP::low-level-prin or CP::prin. | 316 | ;; Could be called as either cust-print-low-level-prin or cust-print-prin. |
| 318 | (cond | 317 | (cond |
| 319 | ((null object) (CP::internal-printer object)) | 318 | ((null object) (cust-print-internal-printer object)) |
| 320 | ((consp object) (CP::list object)) | 319 | ((consp object) (cust-print-list object)) |
| 321 | ((vectorp object) (CP::vector object)) | 320 | ((vectorp object) (cust-print-vector object)) |
| 322 | ;; All other types, just print. | 321 | ;; All other types, just print. |
| 323 | (t (CP::internal-printer object)))) | 322 | (t (cust-print-internal-printer object)))) |
| 324 | 323 | ||
| 325 | 324 | ||
| 326 | (defun CP::custom-object (object) | 325 | ;; Test object type and print accordingly. |
| 327 | "Test object type and print accordingly." | 326 | (defun cust-print-custom-object (object) |
| 328 | ;; Could be called as either CP::low-level-prin or CP::prin. | 327 | ;; Could be called as either cust-print-low-level-prin or cust-print-prin. |
| 329 | (cond | 328 | (cond |
| 330 | ((null object) (CP::internal-printer object)) | 329 | ((null object) (cust-print-internal-printer object)) |
| 331 | 330 | ||
| 332 | ((consp object) | 331 | ((consp object) |
| 333 | (or (and custom-print-list | 332 | (or (and custom-print-list |
| 334 | (CP::custom-object1 object custom-print-list)) | 333 | (cust-print-custom-object1 object custom-print-list)) |
| 335 | (CP::list object))) | 334 | (cust-print-list object))) |
| 336 | 335 | ||
| 337 | ((vectorp object) | 336 | ((vectorp object) |
| 338 | (or (and custom-print-vector | 337 | (or (and custom-print-vector |
| 339 | (CP::custom-object1 object custom-print-vector)) | 338 | (cust-print-custom-object1 object custom-print-vector)) |
| 340 | (CP::vector object))) | 339 | (cust-print-vector object))) |
| 341 | 340 | ||
| 342 | ;; All other types, just print. | 341 | ;; All other types, just print. |
| 343 | (t (CP::internal-printer object)))) | 342 | (t (cust-print-internal-printer object)))) |
| 344 | 343 | ||
| 345 | 344 | ||
| 346 | (defun CP::custom-object1 (object alist) | 345 | ;; Helper for cust-print-custom-object. |
| 347 | "Helper for CP::custom-object. | 346 | ;; Print the custom OBJECT using the custom type ALIST. |
| 348 | Print the custom OBJECT using the custom type ALIST. | 347 | ;; For the first predicate that matches the object, the corresponding |
| 349 | For the first predicate that matches the object, the corresponding | 348 | ;; converter is evaluated with the object and the string that results is |
| 350 | converter is evaluated with the object and the string that results is | 349 | ;; printed with princ. Return nil if no predicte matches the object. |
| 351 | printed with princ. Return nil if no predicte matches the object." | 350 | (defun cust-print-custom-object1 (object alist) |
| 352 | (while (and alist (not (funcall (car (car alist)) object))) | 351 | (while (and alist (not (funcall (car (car alist)) object))) |
| 353 | (setq alist (cdr alist))) | 352 | (setq alist (cdr alist))) |
| 354 | ;; If alist is not null, then something matched. | 353 | ;; If alist is not null, then something matched. |
| 355 | (if alist | 354 | (if alist |
| 356 | (CP::internal-princ | 355 | (cust-print-internal-princ |
| 357 | (funcall (cdr (car alist)) object) ; returns string | 356 | (funcall (cdr (car alist)) object) ; returns string |
| 358 | ))) | 357 | ))) |
| 359 | 358 | ||
| 360 | 359 | ||
| 361 | (defun CP::circular (object) | 360 | (defun cust-print-circular (object) |
| 362 | "Printer for prin1 and princ that handles circular structures. | 361 | "Printer for `prin1' and `princ' that handles circular structures. |
| 363 | If OBJECT appears multiply, and has not yet been printed, | 362 | If OBJECT appears multiply, and has not yet been printed, |
| 364 | prefix with label; if it has been printed, use #n# instead. | 363 | prefix with label; if it has been printed, use `#N#' instead. |
| 365 | Otherwise, print normally." | 364 | Otherwise, print normally." |
| 366 | (let ((tag (assq object circle-table))) | 365 | (let ((tag (assq object circle-table))) |
| 367 | (if tag | 366 | (if tag |
| @@ -369,35 +368,35 @@ Otherwise, print normally." | |||
| 369 | (if (> id 0) | 368 | (if (> id 0) |
| 370 | (progn | 369 | (progn |
| 371 | ;; Already printed, so just print id. | 370 | ;; Already printed, so just print id. |
| 372 | (CP::internal-princ "#") | 371 | (cust-print-internal-princ "#") |
| 373 | (CP::internal-princ id) | 372 | (cust-print-internal-princ id) |
| 374 | (CP::internal-princ "#")) | 373 | (cust-print-internal-princ "#")) |
| 375 | ;; Not printed yet, so label with id and print object. | 374 | ;; Not printed yet, so label with id and print object. |
| 376 | (setcdr tag (- id)) ; mark it as printed | 375 | (setcdr tag (- id)) ; mark it as printed |
| 377 | (CP::internal-princ "#") | 376 | (cust-print-internal-princ "#") |
| 378 | (CP::internal-princ (- id)) | 377 | (cust-print-internal-princ (- id)) |
| 379 | (CP::internal-princ "=") | 378 | (cust-print-internal-princ "=") |
| 380 | (CP::low-level-prin object) | 379 | (cust-print-low-level-prin object) |
| 381 | )) | 380 | )) |
| 382 | ;; Not repeated in structure. | 381 | ;; Not repeated in structure. |
| 383 | (CP::low-level-prin object)))) | 382 | (cust-print-low-level-prin object)))) |
| 384 | 383 | ||
| 385 | 384 | ||
| 386 | ;;================================================ | 385 | ;;================================================ |
| 387 | ;; List and vector processing for print functions. | 386 | ;; List and vector processing for print functions. |
| 388 | 387 | ||
| 389 | (defun CP::list (list) | 388 | ;; Print a list using print-length, print-level, and print-circle. |
| 390 | "Print a list using print-length, print-level, and print-circle." | 389 | (defun cust-print-list (list) |
| 391 | (if (= level 0) | 390 | (if (= level 0) |
| 392 | (CP::internal-princ "#") | 391 | (cust-print-internal-princ "#") |
| 393 | (let ((level (1- level))) | 392 | (let ((level (1- level))) |
| 394 | (CP::internal-princ "(") | 393 | (cust-print-internal-princ "(") |
| 395 | (let ((length (or print-length 0))) | 394 | (let ((length (or print-length 0))) |
| 396 | 395 | ||
| 397 | ;; Print the first element always (even if length = 0). | 396 | ;; Print the first element always (even if length = 0). |
| 398 | (CP::prin (car list)) | 397 | (cust-print-prin (car list)) |
| 399 | (setq list (cdr list)) | 398 | (setq list (cdr list)) |
| 400 | (if list (CP::internal-princ " ")) | 399 | (if list (cust-print-internal-princ " ")) |
| 401 | (setq length (1- length)) | 400 | (setq length (1- length)) |
| 402 | 401 | ||
| 403 | ;; Print the rest of the elements. | 402 | ;; Print the rest of the elements. |
| @@ -405,41 +404,41 @@ Otherwise, print normally." | |||
| 405 | (if (and (listp list) | 404 | (if (and (listp list) |
| 406 | (not (assq list circle-table))) | 405 | (not (assq list circle-table))) |
| 407 | (progn | 406 | (progn |
| 408 | (CP::prin (car list)) | 407 | (cust-print-prin (car list)) |
| 409 | (setq list (cdr list))) | 408 | (setq list (cdr list))) |
| 410 | 409 | ||
| 411 | ;; cdr is not a list, or it is in circle-table. | 410 | ;; cdr is not a list, or it is in circle-table. |
| 412 | (CP::internal-princ ". ") | 411 | (cust-print-internal-princ ". ") |
| 413 | (CP::prin list) | 412 | (cust-print-prin list) |
| 414 | (setq list nil)) | 413 | (setq list nil)) |
| 415 | 414 | ||
| 416 | (setq length (1- length)) | 415 | (setq length (1- length)) |
| 417 | (if list (CP::internal-princ " "))) | 416 | (if list (cust-print-internal-princ " "))) |
| 418 | 417 | ||
| 419 | (if (and list (= length 0)) (CP::internal-princ "...")) | 418 | (if (and list (= length 0)) (cust-print-internal-princ "...")) |
| 420 | (CP::internal-princ ")")))) | 419 | (cust-print-internal-princ ")")))) |
| 421 | list) | 420 | list) |
| 422 | 421 | ||
| 423 | 422 | ||
| 424 | (defun CP::vector (vector) | 423 | ;; Print a vector according to print-length, print-level, and print-circle. |
| 425 | "Print a vector using print-length, print-level, and print-circle." | 424 | (defun cust-print-vector (vector) |
| 426 | (if (= level 0) | 425 | (if (= level 0) |
| 427 | (CP::internal-princ "#") | 426 | (cust-print-internal-princ "#") |
| 428 | (let ((level (1- level)) | 427 | (let ((level (1- level)) |
| 429 | (i 0) | 428 | (i 0) |
| 430 | (len (length vector))) | 429 | (len (length vector))) |
| 431 | (CP::internal-princ "[") | 430 | (cust-print-internal-princ "[") |
| 432 | 431 | ||
| 433 | (if print-length | 432 | (if print-length |
| 434 | (setq len (min print-length len))) | 433 | (setq len (min print-length len))) |
| 435 | ;; Print the elements | 434 | ;; Print the elements |
| 436 | (while (< i len) | 435 | (while (< i len) |
| 437 | (CP::prin (aref vector i)) | 436 | (cust-print-prin (aref vector i)) |
| 438 | (setq i (1+ i)) | 437 | (setq i (1+ i)) |
| 439 | (if (< i (length vector)) (CP::internal-princ " "))) | 438 | (if (< i (length vector)) (cust-print-internal-princ " "))) |
| 440 | 439 | ||
| 441 | (if (< i (length vector)) (CP::internal-princ "...")) | 440 | (if (< i (length vector)) (cust-print-internal-princ "...")) |
| 442 | (CP::internal-princ "]") | 441 | (cust-print-internal-princ "]") |
| 443 | )) | 442 | )) |
| 444 | vector) | 443 | vector) |
| 445 | 444 | ||
| @@ -447,7 +446,7 @@ Otherwise, print normally." | |||
| 447 | ;;================================== | 446 | ;;================================== |
| 448 | ;; Circular structure preprocessing | 447 | ;; Circular structure preprocessing |
| 449 | 448 | ||
| 450 | (defun CP::preprocess-circle-tree (object) | 449 | (defun cust-print-preprocess-circle-tree (object) |
| 451 | ;; Fill up the table. | 450 | ;; Fill up the table. |
| 452 | (let (;; Table of tags for each object in an object to be printed. | 451 | (let (;; Table of tags for each object in an object to be printed. |
| 453 | ;; A tag is of the form: | 452 | ;; A tag is of the form: |
| @@ -457,7 +456,7 @@ Otherwise, print normally." | |||
| 457 | ;; can use setcdr to add new elements instead of having to setq the | 456 | ;; can use setcdr to add new elements instead of having to setq the |
| 458 | ;; variable sometimes (poor man's locf). | 457 | ;; variable sometimes (poor man's locf). |
| 459 | (circle-table (list nil))) | 458 | (circle-table (list nil))) |
| 460 | (CP::walk-circle-tree object) | 459 | (cust-print-walk-circle-tree object) |
| 461 | 460 | ||
| 462 | ;; Reverse table so it is in the order that the objects will be printed. | 461 | ;; Reverse table so it is in the order that the objects will be printed. |
| 463 | ;; This pass could be avoided if we always added to the end of the | 462 | ;; This pass could be avoided if we always added to the end of the |
| @@ -484,7 +483,7 @@ Otherwise, print normally." | |||
| 484 | 483 | ||
| 485 | 484 | ||
| 486 | 485 | ||
| 487 | (defun CP::walk-circle-tree (object) | 486 | (defun cust-print-walk-circle-tree (object) |
| 488 | (let (read-equivalent-p tag) | 487 | (let (read-equivalent-p tag) |
| 489 | (while object | 488 | (while object |
| 490 | (setq read-equivalent-p (or (numberp object) (symbolp object)) | 489 | (setq read-equivalent-p (or (numberp object) (symbolp object)) |
| @@ -506,7 +505,7 @@ Otherwise, print normally." | |||
| 506 | 505 | ||
| 507 | ((consp object) | 506 | ((consp object) |
| 508 | ;; Walk the car of the list recursively. | 507 | ;; Walk the car of the list recursively. |
| 509 | (CP::walk-circle-tree (car object)) | 508 | (cust-print-walk-circle-tree (car object)) |
| 510 | ;; But walk the cdr with the above while loop | 509 | ;; But walk the cdr with the above while loop |
| 511 | ;; to avoid problems with max-lisp-eval-depth. | 510 | ;; to avoid problems with max-lisp-eval-depth. |
| 512 | ;; And it should be faster than recursion. | 511 | ;; And it should be faster than recursion. |
| @@ -517,7 +516,7 @@ Otherwise, print normally." | |||
| 517 | (let ((i (length object)) | 516 | (let ((i (length object)) |
| 518 | (j 0)) | 517 | (j 0)) |
| 519 | (while (< j i) | 518 | (while (< j i) |
| 520 | (CP::walk-circle-tree (aref object j)) | 519 | (cust-print-walk-circle-tree (aref object j)) |
| 521 | (setq j (1+ j)))))))))) | 520 | (setq j (1+ j)))))))))) |
| 522 | 521 | ||
| 523 | 522 | ||