# HG changeset patch # User Richard M. Stallman # Date 718448959 0 # Node ID 96c43cee31f1d9b195ab679dbe1f4f62ebeb50bf # Parent aa32c275cbf9d0cb4f3dad473d292e48f713c5fd CP:: changed to cust-print- in all names. Lots of doc fixes. diff -r aa32c275cbf9 -r 96c43cee31f1 lisp/emacs-lisp/cust-print.el --- a/lisp/emacs-lisp/cust-print.el Tue Oct 06 22:02:49 1992 +0000 +++ b/lisp/emacs-lisp/cust-print.el Wed Oct 07 09:09:19 1992 +0000 @@ -93,7 +93,6 @@ ;;; Code: (provide 'custom-print) -;; Abbreviated package name: "CP" ;;(defvar print-length nil ;; "*Controls how many elements of a list, at each level, are printed. @@ -104,10 +103,10 @@ If nil, printing proceeds recursively and may lead to max-lisp-eval-depth being exceeded or an untrappable error may occur: -\"Apparently circular structure being printed.\" Also see -print-length and print-circle. +`Apparently circular structure being printed.' +Also see `print-length' and `print-circle'. -If non-nil, components at levels equal to or greater than print-level +If non-nil, components at levels equal to or greater than `print-level' are printed simply as \"#\". The object to be printed is at level 0, and if the object is a list or vector, its top-level components are at level 1.") @@ -117,14 +116,14 @@ "*Controls the printing of recursive structures. If nil, printing proceeds recursively and may lead to -max-lisp-eval-depth being exceeded or an untrappable error may occur: +`max-lisp-eval-depth' being exceeded or an untrappable error may occur: \"Apparently circular structure being printed.\" Also see -print-length and print-level. +`print-length' and `print-level'. If non-nil, shared substructures anywhere in the structure are printed -with \"#n=\" before the first occurance (in the order of the print -representation) and \"#n#\" in place of each subsequent occurance, -where n is a positive decimal integer. +with `#N=' before the first occurance (in the order of the print +representation) and `#N#' in place of each subsequent occurance, +where N is a positive decimal integer. Currently, there is no way to read this representation in Emacs.") @@ -132,23 +131,23 @@ (defconst custom-print-list nil ;; e.g. '((floatp . float-to-string)) - "If non-nil, an alist for printing of custom list objects. -Pairs are of the form (pred . converter). If the predicate is true -for an object, the converter is called with the object and should -return a string which will be printed with princ. -Also see custom-print-vector.") + "An alist for custom printing of lists. +Pairs are of the form (PRED . CONVERTER). If PREDICATE is true +for an object, then CONVERTER is called with the object and should +return a string to be printed with `princ'. +Also see `custom-print-vector'.") (defconst custom-print-vector nil - "If non-nil, an alist for printing of custom vector objects. -Pairs are of the form (pred . converter). If the predicate is true -for an object, the converter is called with the object and should -return a string which will be printed with princ. -Also see custom-print-list.") + "An alist for custom printing of vectors. +Pairs are of the form (PRED . CONVERTER). If PREDICATE is true +for an object, then CONVERTER is called with the object and should +return a string to be printed with `princ'. +Also see `custom-print-list'.") (defun add-custom-print-list (pred converter) - "Add the pair, a PREDICATE and a CONVERTER, to custom-print-list. + "Add a pair of PREDICATE and CONVERTER to `custom-print-list'. Any pair that has the same PREDICATE is first removed." (setq custom-print-list (cons (cons pred converter) (delq (assq pred custom-print-list) @@ -157,7 +156,7 @@ (defun add-custom-print-vector (pred converter) - "Add the pair, a PREDICATE and a CONVERTER, to custom-print-vector. + "Add a pair of PREDICATE and CONVERTER to `custom-print-vector'. Any pair that has the same PREDICATE is first removed." (setq custom-print-vector (cons (cons pred converter) (delq (assq pred custom-print-vector) @@ -167,28 +166,28 @@ ;;==================================================== ;; Saving and restoring internal printing routines. -(defun CP::set-function-cell (symbol-pair) +(defun cust-print-set-function-cell (symbol-pair) (fset (car symbol-pair) (symbol-function (car (cdr symbol-pair))))) -(if (not (fboundp 'CP::internal-prin1)) - (mapcar 'CP::set-function-cell - '((CP::internal-prin1 prin1) - (CP::internal-princ princ) - (CP::internal-print print) - (CP::internal-prin1-to-string prin1-to-string) - (CP::internal-format format) - (CP::internal-message message) - (CP::internal-error error)))) +(if (not (fboundp 'cust-print-internal-prin1)) + (mapcar 'cust-print-set-function-cell + '((cust-print-internal-prin1 prin1) + (cust-print-internal-princ princ) + (cust-print-internal-print print) + (cust-print-internal-prin1-to-string prin1-to-string) + (cust-print-internal-format format) + (cust-print-internal-message message) + (cust-print-internal-error error)))) (defun install-custom-print-funcs () - "Replace print functions with general, customizable, lisp versions. -The internal subroutines are saved away and may be recovered with -uninstall-custom-print-funcs." + "Replace print functions with general, customizable, Lisp versions. +The internal subroutines are saved away, and you can reinstall them +by running `uninstall-custom-print-funcs'." (interactive) - (mapcar 'CP::set-function-cell + (mapcar 'cust-print-set-function-cell '((prin1 custom-prin1) (princ custom-princ) (print custom-print) @@ -201,14 +200,14 @@ (defun uninstall-custom-print-funcs () "Reset print functions to their internal subroutines." (interactive) - (mapcar 'CP::set-function-cell - '((prin1 CP::internal-prin1) - (princ CP::internal-princ) - (print CP::internal-print) - (prin1-to-string CP::internal-prin1-to-string) - (format CP::internal-format) - (message CP::internal-message) - (error CP::internal-error) + (mapcar 'cust-print-set-function-cell + '((prin1 cust-print-internal-prin1) + (princ cust-print-internal-princ) + (print cust-print-internal-print) + (prin1-to-string cust-print-internal-prin1-to-string) + (format cust-print-internal-format) + (message cust-print-internal-message) + (error cust-print-internal-error) ))) @@ -217,47 +216,47 @@ ;; (or princ) -- so far only the printing and formatting subrs. (defun custom-prin1 (object &optional stream) - "Replacement for standard prin1. -Uses the appropriate printer depending on the values of print-level -and print-circle (which see). + "Replacement for standard `prin1'. +Uses the appropriate printer depending on the values of `print-level' +and `print-circle' (which see). Output the printed representation of OBJECT, any Lisp object. Quoting characters are printed when needed to make output that `read' can handle, whenever this is possible. Output stream is STREAM, or value of `standard-output' (which see)." - (CP::top-level object stream 'CP::internal-prin1)) + (cust-print-top-level object stream 'cust-print-internal-prin1)) (defun custom-princ (object &optional stream) - "Same as custom-prin1 except no quoting." - (CP::top-level object stream 'CP::internal-princ)) + "Same as `custom-prin1' except no quoting." + (cust-print-top-level object stream 'cust-print-internal-princ)) (defun custom-prin1-to-string-func (c) - "Stream function for custom-prin1-to-string." + "Stream function for `custom-prin1-to-string'." (setq prin1-chars (cons c prin1-chars))) (defun custom-prin1-to-string (object) - "Replacement for standard prin1-to-string." + "Replacement for standard `prin1-to-string'." (let ((prin1-chars nil)) (custom-prin1 object 'custom-prin1-to-string-func) (concat (nreverse prin1-chars)))) (defun custom-print (object &optional stream) - "Replacement for standard print." - (CP::internal-princ "\n") + "Replacement for standard `print'." + (cust-print-internal-princ "\n") (custom-prin1 object stream) - (CP::internal-princ "\n")) + (cust-print-internal-princ "\n")) (defun custom-format (fmt &rest args) - "Replacement for standard format. + "Replacement for standard `format'. Calls format after first making strings for list or vector args. -The format specification for such args should be %s in any case, so a +The format specification for such args should be `%s' in any case, so a string argument will also work. The string is generated with -custom-prin1-to-string, which quotes quotable characters." - (apply 'CP::internal-format fmt +`custom-prin1-to-string', which quotes quotable characters." + (apply 'cust-print-internal-format fmt (mapcar (function (lambda (arg) (if (or (listp arg) (vectorp arg)) (custom-prin1-to-string arg) @@ -267,12 +266,12 @@ (defun custom-message (fmt &rest args) - "Replacement for standard message that works like custom-format." + "Replacement for standard `message' that works like `custom-format'." ;; It doesnt work to princ the result of custom-format ;; because the echo area requires special handling - ;; to avoid duplicating the output. CP::internal-message does it right. - ;; (CP::internal-princ (apply 'custom-format fmt args)) - (apply 'CP::internal-message fmt + ;; to avoid duplicating the output. cust-print-internal-message does it right. + ;; (cust-print-internal-princ (apply 'custom-format fmt args)) + (apply 'cust-print-internal-message fmt (mapcar (function (lambda (arg) (if (or (listp arg) (vectorp arg)) (custom-prin1-to-string arg) @@ -281,87 +280,87 @@ (defun custom-error (fmt &rest args) - "Replacement for standard error that uses custom-format" + "Replacement for standard `error' that uses `custom-format'" (signal 'error (list (apply 'custom-format fmt args)))) ;;========================================= ;; Support for custom prin1 and princ -(defun CP::top-level (object stream internal-printer) +(defun cust-print-top-level (object stream internal-printer) "Set up for printing." (let ((standard-output (or stream standard-output)) - (circle-table (and print-circle (CP::preprocess-circle-tree object))) + (circle-table (and print-circle (cust-print-preprocess-circle-tree object))) (level (or print-level -1)) ) - (fset 'CP::internal-printer internal-printer) - (fset 'CP::low-level-prin + (fset 'cust-print-internal-printer internal-printer) + (fset 'cust-print-low-level-prin (cond ((or custom-print-list custom-print-vector print-level ; comment out for version 19 ) - 'CP::custom-object) + 'cust-print-custom-object) (circle-table - 'CP::object) - (t 'CP::internal-printer))) - (fset 'CP::prin (if circle-table 'CP::circular 'CP::low-level-prin)) + 'cust-print-object) + (t 'cust-print-internal-printer))) + (fset 'cust-print-prin (if circle-table 'cust-print-circular 'cust-print-low-level-prin)) - (CP::prin object) + (cust-print-prin object) object)) -(defun CP::object (object) - "Test object type and print accordingly." - ;; Could be called as either CP::low-level-prin or CP::prin. +;; Test object type and print accordingly. +(defun cust-print-object (object) + ;; Could be called as either cust-print-low-level-prin or cust-print-prin. (cond - ((null object) (CP::internal-printer object)) - ((consp object) (CP::list object)) - ((vectorp object) (CP::vector object)) + ((null object) (cust-print-internal-printer object)) + ((consp object) (cust-print-list object)) + ((vectorp object) (cust-print-vector object)) ;; All other types, just print. - (t (CP::internal-printer object)))) + (t (cust-print-internal-printer object)))) -(defun CP::custom-object (object) - "Test object type and print accordingly." - ;; Could be called as either CP::low-level-prin or CP::prin. +;; Test object type and print accordingly. +(defun cust-print-custom-object (object) + ;; Could be called as either cust-print-low-level-prin or cust-print-prin. (cond - ((null object) (CP::internal-printer object)) + ((null object) (cust-print-internal-printer object)) ((consp object) (or (and custom-print-list - (CP::custom-object1 object custom-print-list)) - (CP::list object))) + (cust-print-custom-object1 object custom-print-list)) + (cust-print-list object))) ((vectorp object) (or (and custom-print-vector - (CP::custom-object1 object custom-print-vector)) - (CP::vector object))) + (cust-print-custom-object1 object custom-print-vector)) + (cust-print-vector object))) ;; All other types, just print. - (t (CP::internal-printer object)))) + (t (cust-print-internal-printer object)))) -(defun CP::custom-object1 (object alist) - "Helper for CP::custom-object. -Print the custom OBJECT using the custom type ALIST. -For the first predicate that matches the object, the corresponding -converter is evaluated with the object and the string that results is -printed with princ. Return nil if no predicte matches the object." +;; Helper for cust-print-custom-object. +;; Print the custom OBJECT using the custom type ALIST. +;; For the first predicate that matches the object, the corresponding +;; converter is evaluated with the object and the string that results is +;; printed with princ. Return nil if no predicte matches the object. +(defun cust-print-custom-object1 (object alist) (while (and alist (not (funcall (car (car alist)) object))) (setq alist (cdr alist))) ;; If alist is not null, then something matched. (if alist - (CP::internal-princ + (cust-print-internal-princ (funcall (cdr (car alist)) object) ; returns string ))) -(defun CP::circular (object) - "Printer for prin1 and princ that handles circular structures. +(defun cust-print-circular (object) + "Printer for `prin1' and `princ' that handles circular structures. If OBJECT appears multiply, and has not yet been printed, -prefix with label; if it has been printed, use #n# instead. +prefix with label; if it has been printed, use `#N#' instead. Otherwise, print normally." (let ((tag (assq object circle-table))) (if tag @@ -369,35 +368,35 @@ (if (> id 0) (progn ;; Already printed, so just print id. - (CP::internal-princ "#") - (CP::internal-princ id) - (CP::internal-princ "#")) + (cust-print-internal-princ "#") + (cust-print-internal-princ id) + (cust-print-internal-princ "#")) ;; Not printed yet, so label with id and print object. (setcdr tag (- id)) ; mark it as printed - (CP::internal-princ "#") - (CP::internal-princ (- id)) - (CP::internal-princ "=") - (CP::low-level-prin object) + (cust-print-internal-princ "#") + (cust-print-internal-princ (- id)) + (cust-print-internal-princ "=") + (cust-print-low-level-prin object) )) ;; Not repeated in structure. - (CP::low-level-prin object)))) + (cust-print-low-level-prin object)))) ;;================================================ ;; List and vector processing for print functions. -(defun CP::list (list) - "Print a list using print-length, print-level, and print-circle." +;; Print a list using print-length, print-level, and print-circle. +(defun cust-print-list (list) (if (= level 0) - (CP::internal-princ "#") + (cust-print-internal-princ "#") (let ((level (1- level))) - (CP::internal-princ "(") + (cust-print-internal-princ "(") (let ((length (or print-length 0))) ;; Print the first element always (even if length = 0). - (CP::prin (car list)) + (cust-print-prin (car list)) (setq list (cdr list)) - (if list (CP::internal-princ " ")) + (if list (cust-print-internal-princ " ")) (setq length (1- length)) ;; Print the rest of the elements. @@ -405,41 +404,41 @@ (if (and (listp list) (not (assq list circle-table))) (progn - (CP::prin (car list)) + (cust-print-prin (car list)) (setq list (cdr list))) ;; cdr is not a list, or it is in circle-table. - (CP::internal-princ ". ") - (CP::prin list) + (cust-print-internal-princ ". ") + (cust-print-prin list) (setq list nil)) (setq length (1- length)) - (if list (CP::internal-princ " "))) + (if list (cust-print-internal-princ " "))) - (if (and list (= length 0)) (CP::internal-princ "...")) - (CP::internal-princ ")")))) + (if (and list (= length 0)) (cust-print-internal-princ "...")) + (cust-print-internal-princ ")")))) list) -(defun CP::vector (vector) - "Print a vector using print-length, print-level, and print-circle." +;; Print a vector according to print-length, print-level, and print-circle. +(defun cust-print-vector (vector) (if (= level 0) - (CP::internal-princ "#") + (cust-print-internal-princ "#") (let ((level (1- level)) (i 0) (len (length vector))) - (CP::internal-princ "[") + (cust-print-internal-princ "[") (if print-length (setq len (min print-length len))) ;; Print the elements (while (< i len) - (CP::prin (aref vector i)) + (cust-print-prin (aref vector i)) (setq i (1+ i)) - (if (< i (length vector)) (CP::internal-princ " "))) + (if (< i (length vector)) (cust-print-internal-princ " "))) - (if (< i (length vector)) (CP::internal-princ "...")) - (CP::internal-princ "]") + (if (< i (length vector)) (cust-print-internal-princ "...")) + (cust-print-internal-princ "]") )) vector) @@ -447,7 +446,7 @@ ;;================================== ;; Circular structure preprocessing -(defun CP::preprocess-circle-tree (object) +(defun cust-print-preprocess-circle-tree (object) ;; Fill up the table. (let (;; Table of tags for each object in an object to be printed. ;; A tag is of the form: @@ -457,7 +456,7 @@ ;; can use setcdr to add new elements instead of having to setq the ;; variable sometimes (poor man's locf). (circle-table (list nil))) - (CP::walk-circle-tree object) + (cust-print-walk-circle-tree object) ;; Reverse table so it is in the order that the objects will be printed. ;; This pass could be avoided if we always added to the end of the @@ -484,7 +483,7 @@ -(defun CP::walk-circle-tree (object) +(defun cust-print-walk-circle-tree (object) (let (read-equivalent-p tag) (while object (setq read-equivalent-p (or (numberp object) (symbolp object)) @@ -506,7 +505,7 @@ ((consp object) ;; Walk the car of the list recursively. - (CP::walk-circle-tree (car object)) + (cust-print-walk-circle-tree (car object)) ;; But walk the cdr with the above while loop ;; to avoid problems with max-lisp-eval-depth. ;; And it should be faster than recursion. @@ -517,7 +516,7 @@ (let ((i (length object)) (j 0)) (while (< j i) - (CP::walk-circle-tree (aref object j)) + (cust-print-walk-circle-tree (aref object j)) (setq j (1+ j))))))))))