;; LCD Archive Entry:
;; cust-print|Daniel LaLiberte|liberte@cs.uiuc.edu
;; |Handle print-level, print-circle and more.
-;; |$Date: 1994/04/05 21:05:09 $|$Revision: 1.14 $|
;; This file is part of GNU Emacs.
;; GNU General Public License for more details.
;; You should have received a copy of the GNU General Public License
-;; along with GNU Emacs; see the file COPYING. If not, write to
-;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
-
-;;; ===============================
-;;; $Header: $
-;;; $Log: cust-print.el,v $
-;;; Revision 1.14 1994/04/05 21:05:09 liberte
-;;; Change install- and uninstall- to -install and -uninstall.
-;;;
-;;; Revision 1.13 1994/03/24 20:26:05 liberte
-;;; Change "internal" to "original" throughout.
-;;; (add-custom-printer, delete-custom-printer) replace customizers.
-;;; (with-custom-print) new
-;;; (custom-prin1-to-string) Made it more robust.
-;;;
-;;; Revision 1.4 1994/03/23 20:34:29 liberte
-;;; * Change "emacs" to "original" - I just can't decide.
-;;;
-;;; Revision 1.3 1994/02/21 21:25:36 liberte
-;;; * Make custom-prin1-to-string more robust when errors occur.
-;;; * Change "internal" to "emacs".
-;;;
-;;; Revision 1.2 1993/11/22 22:36:36 liberte
-;;; * Simplified and generalized printer customization.
-;;; custom-printers is an alist of (PREDICATE . PRINTER) pairs
-;;; for any data types. The PRINTER function should print to
-;;; `standard-output' add-custom-printer and delete-custom-printer
-;;; change custom-printers.
-;;;
-;;; * Installation function now called install-custom-print. The
-;;; old name is still around for now.
-;;;
-;;; * New macro with-custom-print (added earlier) - executes like
-;;; progn but with custom-print activated temporarily.
-;;;
-;;; * Cleaned up comments for replacements of standardard printers.
-;;;
-;;; * Changed custom-prin1-to-string to use a temporary buffer.
-;;;
-;;; * Option custom-print-vectors (added earlier) - controls whether
-;;; vectors should be printed according to print-length and
-;;; print-length. Emacs doesnt do this, but cust-print would
-;;; otherwise do it only if custom printing is required.
-;;;
-;;; * Uninterned symbols are treated as non-read-equivalent.
-;;;
+;; along with GNU Emacs; see the file COPYING. If not, write to the
+;; Free Software Foundation, Inc., 59 Temple Place - Suite 330,
+;; Boston, MA 02111-1307, USA.
-\f
;;; Commentary:
;; This package provides a general print handler for prin1 and princ
\f
;;; Code:
-;;=========================================================
+
+(defgroup cust-print nil
+ "Handles print-level and print-circle."
+ :prefix "print-"
+ :group 'lisp
+ :group 'extensions)
;; If using cl-packages:
'(in-package cust-print)
-(require 'backquote)
-
-;; Emacs 18 doesnt have defalias.
+;; Emacs 18 doesn't have defalias.
;; Provide def for byte compiler.
(eval-and-compile
(or (fboundp 'defalias) (fset 'defalias 'fset)))
;; "*Controls how many elements of a list, at each level, are printed.
;;This is defined by emacs.")
-(defvar print-level nil
+(defcustom print-level nil
"*Controls how many levels deep a nested data object will print.
If nil, printing proceeds recursively and may lead to
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.")
+level 1."
+ :type '(choice (const nil) integer)
+ :group 'cust-print)
-(defvar print-circle nil
+(defcustom print-circle nil
"*Controls the printing of recursive structures.
If nil, printing proceeds recursively and may lead to
where N is a positive decimal integer.
There is no way to read this representation in standard Emacs,
-but if you need to do so, try the cl-read.el package.")
+but if you need to do so, try the cl-read.el package."
+ :type 'boolean
+ :group 'cust-print)
-(defvar custom-print-vectors nil
+(defcustom custom-print-vectors nil
"*Non-nil if printing of vectors should obey print-level and print-length.
For Emacs 18, setting print-level, or adding custom print list or
vector handling will make this happen anyway. Emacs 19 obeys
-print-level, but not for vectors.")
+print-level, but not for vectors."
+ :type 'boolean
+ :group 'cust-print)
\f
;; Custom printers
`delete-custom-printer'")
;; Should cust-print-original-princ and cust-print-prin be exported symbols?
;; Or should the standard printers functions be replaced by
-;; CP ones in elisp so that CP internal functions need not be called?
+;; CP ones in Emacs Lisp so that CP internal functions need not be called?
(defun add-custom-printer (pred printer)
"Add a pair of PREDICATE and PRINTER to `custom-printers'.
(defun cust-print-update-custom-printers ()
;; Modify the definition of cust-print-use-custom-printer
(defalias 'cust-print-use-custom-printer
- ;; We dont really want to require the byte-compiler.
+ ;; We don't really want to require the byte-compiler.
;; (byte-compile
- (` (lambda (object)
- (cond
- (,@ (mapcar (function
- (lambda (pair)
- (` (((, (car pair)) object)
- ((, (cdr pair)) object)))))
- custom-printers))
- ;; Otherwise return nil.
- (t nil)
- )))
- ;; )
- ))
+ `(lambda (object)
+ (cond
+ ,@(mapcar (function
+ (lambda (pair)
+ `((,(car pair) object)
+ (,(cdr pair) object))))
+ custom-printers)
+ ;; Otherwise return nil.
+ (t nil)
+ ))
+ ;; )
+ ))
\f
;; Saving and restoring emacs printing routines.
(defalias 'with-custom-print-funcs 'with-custom-print)
(defmacro with-custom-print (&rest body)
"Temporarily install the custom print package while executing BODY."
- (` (unwind-protect
- (progn
- (custom-print-install)
- (,@ body))
- (custom-print-uninstall))))
+ `(unwind-protect
+ (progn
+ (custom-print-install)
+ ,@body)
+ (custom-print-uninstall)))
\f
;; Lisp replacements for prin1 and princ, and for some subrs that use them
(cust-print-top-level object stream 'cust-print-original-princ))
-(defun custom-prin1-to-string (object)
+(defun custom-prin1-to-string (object &optional noescape)
"Return a string containing the printed representation of OBJECT,
any Lisp object. Quoting characters are used when needed to make output
-that `read' can handle, whenever this is possible.
+that `read' can handle, whenever this is possible, unless the optional
+second argument NOESCAPE is non-nil.
This is the custom-print replacement for the standard `prin1-to-string'."
(let ((buf (get-buffer-create " *custom-print-temp*")))
;; We must erase the buffer before printing in case an error
- ;; occured during the last prin1-to-string and we are in debugger.
+ ;; occurred during the last prin1-to-string and we are in debugger.
(save-excursion
(set-buffer buf)
(erase-buffer))
;; We must be in the current-buffer when the print occurs.
- (custom-prin1 object buf)
+ (if noescape
+ (custom-princ object buf)
+ (custom-prin1 object buf))
(save-excursion
(set-buffer buf)
(buffer-string)
"Set the edebug-form-spec property of SYMBOL according to SPEC.
Both SYMBOL and SPEC are unevaluated. The SPEC can be 0, t, a symbol
\(naming a function), or a list."
- (` (put (quote (, symbol)) 'edebug-form-spec (quote (, spec)))))
+ `(put (quote ,symbol) 'edebug-form-spec (quote ,spec)))
(defmacro def-edebug-form-spec (symbol spec-form)
"For compatibility with old version. Use `def-edebug-spec' instead."
and the restriction will be restored to the original buffer,
and the current buffer remains current.
Return the result of the last expression in BODY."
- (` (let ((edebug:s-r-beg (point-min-marker))
- (edebug:s-r-end (point-max-marker)))
- (unwind-protect
- (progn (,@ body))
- (save-excursion
- (set-buffer (marker-buffer edebug:s-r-beg))
- (narrow-to-region edebug:s-r-beg edebug:s-r-end))))))
+ `(let ((edebug:s-r-beg (point-min-marker))
+ (edebug:s-r-end (point-max-marker)))
+ (unwind-protect
+ (progn ,@body)
+ (save-excursion
+ (set-buffer (marker-buffer edebug:s-r-beg))
+ (narrow-to-region edebug:s-r-beg edebug:s-r-end)))))
;;; Display
(put 'edebug-storing-offsets 'lisp-indent-hook 1)
(defmacro edebug-storing-offsets (point &rest body)
- (` (unwind-protect
- (progn
- (edebug-store-before-offset (, point))
- (,@ body))
- (edebug-store-after-offset (point)))))
+ `(unwind-protect
+ (progn
+ (edebug-store-before-offset ,point)
+ ,@body)
+ (edebug-store-after-offset (point))))
;;; Reader for Emacs Lisp.
(defun edebug-wrap-def-body (forms)
"Wrap the FORMS of a definition body."
(if edebug-def-interactive
- (` (let (((, (edebug-interactive-p-name))
- (interactive-p)))
- (, (edebug-make-enter-wrapper forms))))
+ `(let ((,(edebug-interactive-p-name)
+ (interactive-p)))
+ ,(edebug-make-enter-wrapper forms))
(edebug-make-enter-wrapper forms)))
;; Do this after parsing since that may find a name.
(setq edebug-def-name
(or edebug-def-name edebug-old-def-name (edebug-gensym "edebug-anon")))
- (` (edebug-enter
- (quote (, edebug-def-name))
- (, (if edebug-inside-func
- (` (list (,@
- ;; Doesn't work with more than one def-body!!
- ;; But the list will just be reversed.
- (nreverse edebug-def-args))))
- 'nil))
- (function (lambda () (,@ forms)))
- )))
+ `(edebug-enter
+ (quote ,edebug-def-name)
+ ,(if edebug-inside-func
+ `(list (;; Doesn't work with more than one def-body!!
+ ;; But the list will just be reversed.
+ ,@(nreverse edebug-def-args)))
+ 'nil)
+ (function (lambda () ,@forms))
+ ))
(defvar edebug-form-begin-marker) ; the mark for def being instrumented
(defmacro edebug-tracing (msg &rest body)
"Print MSG in *edebug-trace* before and after evaluating BODY.
The result of BODY is also printed."
- (` (let ((edebug-stack-depth (1+ edebug-stack-depth))
- edebug-result)
- (edebug-print-trace-before (, msg))
- (prog1 (setq edebug-result (progn (,@ body)))
- (edebug-print-trace-after
- (format "%s result: %s" (, msg) edebug-result))))))
+ `(let ((edebug-stack-depth (1+ edebug-stack-depth))
+ edebug-result)
+ (edebug-print-trace-before ,msg)
+ (prog1 (setq edebug-result (progn ,@body))
+ (edebug-print-trace-after
+ (format "%s result: %s" ,msg edebug-result)))))
(defun edebug-print-trace-before (msg)
"Function called to print trace info before expression evaluation.
(if edebug-save-windows "on" "off")))
(defmacro edebug-changing-windows (&rest body)
- (` (let ((window (selected-window)))
- (setq edebug-inside-windows (edebug-current-windows t))
- (edebug-set-windows edebug-outside-windows)
- (,@ body) ;; Code to change edebug-save-windows
- (setq edebug-outside-windows (edebug-current-windows
- edebug-save-windows))
- ;; Problem: what about outside windows that are deleted inside?
- (edebug-set-windows edebug-inside-windows))))
+ `(let ((window (selected-window)))
+ (setq edebug-inside-windows (edebug-current-windows t))
+ (edebug-set-windows edebug-outside-windows)
+ ,@body;; Code to change edebug-save-windows
+ (setq edebug-outside-windows (edebug-current-windows
+ edebug-save-windows))
+ ;; Problem: what about outside windows that are deleted inside?
+ (edebug-set-windows edebug-inside-windows)))
(defun edebug-toggle-save-selected-window ()
"Toggle the saving and restoring of the selected window.
(defmacro edebug-outside-excursion (&rest body)
"Evaluate an expression list in the outside context.
Return the result of the last expression."
- (` (save-excursion ; of current-buffer
- (if edebug-save-windows
- (progn
- ;; After excursion, we will
- ;; restore to current window configuration.
- (setq edebug-inside-windows
- (edebug-current-windows edebug-save-windows))
- ;; Restore outside windows.
- (edebug-set-windows edebug-outside-windows)))
-
- (set-buffer edebug-buffer) ; why?
- ;; (use-local-map edebug-outside-map)
- (set-match-data edebug-outside-match-data)
- ;; Restore outside context.
- (let (;; (edebug-inside-map (current-local-map)) ;; restore map??
- (last-command-char edebug-outside-last-command-char)
- (last-command-event edebug-outside-last-command-event)
- (last-command edebug-outside-last-command)
- (this-command edebug-outside-this-command)
- (unread-command-char edebug-outside-unread-command-char)
- (unread-command-event edebug-outside-unread-command-event)
- (unread-command-events edebug-outside-unread-command-events)
- (current-prefix-arg edebug-outside-current-prefix-arg)
- (last-input-char edebug-outside-last-input-char)
- (last-input-event edebug-outside-last-input-event)
- (last-event-frame edebug-outside-last-event-frame)
- (last-nonmenu-event edebug-outside-last-nonmenu-event)
- (track-mouse edebug-outside-track-mouse)
- (standard-output edebug-outside-standard-output)
- (standard-input edebug-outside-standard-input)
-
- (executing-kbd-macro edebug-outside-executing-macro)
- (defining-kbd-macro edebug-outside-defining-kbd-macro)
- (pre-command-hook edebug-outside-pre-command-hook)
- (post-command-hook edebug-outside-post-command-hook)
-
- ;; See edebug-display
- (overlay-arrow-position edebug-outside-o-a-p)
- (overlay-arrow-string edebug-outside-o-a-s)
- (cursor-in-echo-area edebug-outside-c-i-e-a)
- )
- (unwind-protect
- (save-excursion ; of edebug-buffer
- (set-buffer edebug-outside-buffer)
- (goto-char edebug-outside-point)
- (if (marker-buffer (edebug-mark-marker))
- (set-marker (edebug-mark-marker) edebug-outside-mark))
- (,@ body))
-
- ;; Back to edebug-buffer. Restore rest of inside context.
- ;; (use-local-map edebug-inside-map)
- (if edebug-save-windows
- ;; Restore inside windows.
- (edebug-set-windows edebug-inside-windows))
-
- ;; Save values that may have been changed.
- (setq
- edebug-outside-last-command-char last-command-char
- edebug-outside-last-command-event last-command-event
- edebug-outside-last-command last-command
- edebug-outside-this-command this-command
- edebug-outside-unread-command-char unread-command-char
- edebug-outside-unread-command-event unread-command-event
- edebug-outside-unread-command-events unread-command-events
- edebug-outside-current-prefix-arg current-prefix-arg
- edebug-outside-last-input-char last-input-char
- edebug-outside-last-input-event last-input-event
- edebug-outside-last-event-frame last-event-frame
- edebug-outside-last-nonmenu-event last-nonmenu-event
- edebug-outside-track-mouse track-mouse
- edebug-outside-standard-output standard-output
- edebug-outside-standard-input standard-input
-
- edebug-outside-executing-macro executing-kbd-macro
- edebug-outside-defining-kbd-macro defining-kbd-macro
- edebug-outside-pre-command-hook pre-command-hook
- edebug-outside-post-command-hook post-command-hook
-
- edebug-outside-o-a-p overlay-arrow-position
- edebug-outside-o-a-s overlay-arrow-string
- edebug-outside-c-i-e-a cursor-in-echo-area
- ))) ; let
- )))
+ `(save-excursion ; of current-buffer
+ (if edebug-save-windows
+ (progn
+ ;; After excursion, we will
+ ;; restore to current window configuration.
+ (setq edebug-inside-windows
+ (edebug-current-windows edebug-save-windows))
+ ;; Restore outside windows.
+ (edebug-set-windows edebug-outside-windows)))
+
+ (set-buffer edebug-buffer) ; why?
+ ;; (use-local-map edebug-outside-map)
+ (set-match-data edebug-outside-match-data)
+ ;; Restore outside context.
+ (let (;; (edebug-inside-map (current-local-map)) ;; restore map??
+ (last-command-char edebug-outside-last-command-char)
+ (last-command-event edebug-outside-last-command-event)
+ (last-command edebug-outside-last-command)
+ (this-command edebug-outside-this-command)
+ (unread-command-char edebug-outside-unread-command-char)
+ (unread-command-event edebug-outside-unread-command-event)
+ (unread-command-events edebug-outside-unread-command-events)
+ (current-prefix-arg edebug-outside-current-prefix-arg)
+ (last-input-char edebug-outside-last-input-char)
+ (last-input-event edebug-outside-last-input-event)
+ (last-event-frame edebug-outside-last-event-frame)
+ (last-nonmenu-event edebug-outside-last-nonmenu-event)
+ (track-mouse edebug-outside-track-mouse)
+ (standard-output edebug-outside-standard-output)
+ (standard-input edebug-outside-standard-input)
+
+ (executing-kbd-macro edebug-outside-executing-macro)
+ (defining-kbd-macro edebug-outside-defining-kbd-macro)
+ (pre-command-hook edebug-outside-pre-command-hook)
+ (post-command-hook edebug-outside-post-command-hook)
+
+ ;; See edebug-display
+ (overlay-arrow-position edebug-outside-o-a-p)
+ (overlay-arrow-string edebug-outside-o-a-s)
+ (cursor-in-echo-area edebug-outside-c-i-e-a)
+ )
+ (unwind-protect
+ (save-excursion ; of edebug-buffer
+ (set-buffer edebug-outside-buffer)
+ (goto-char edebug-outside-point)
+ (if (marker-buffer (edebug-mark-marker))
+ (set-marker (edebug-mark-marker) edebug-outside-mark))
+ ,@body)
+
+ ;; Back to edebug-buffer. Restore rest of inside context.
+ ;; (use-local-map edebug-inside-map)
+ (if edebug-save-windows
+ ;; Restore inside windows.
+ (edebug-set-windows edebug-inside-windows))
+
+ ;; Save values that may have been changed.
+ (setq
+ edebug-outside-last-command-char last-command-char
+ edebug-outside-last-command-event last-command-event
+ edebug-outside-last-command last-command
+ edebug-outside-this-command this-command
+ edebug-outside-unread-command-char unread-command-char
+ edebug-outside-unread-command-event unread-command-event
+ edebug-outside-unread-command-events unread-command-events
+ edebug-outside-current-prefix-arg current-prefix-arg
+ edebug-outside-last-input-char last-input-char
+ edebug-outside-last-input-event last-input-event
+ edebug-outside-last-event-frame last-event-frame
+ edebug-outside-last-nonmenu-event last-nonmenu-event
+ edebug-outside-track-mouse track-mouse
+ edebug-outside-standard-output standard-output
+ edebug-outside-standard-input standard-input
+
+ edebug-outside-executing-macro executing-kbd-macro
+ edebug-outside-defining-kbd-macro defining-kbd-macro
+ edebug-outside-pre-command-hook pre-command-hook
+ edebug-outside-post-command-hook post-command-hook
+
+ edebug-outside-o-a-p overlay-arrow-position
+ edebug-outside-o-a-s overlay-arrow-string
+ edebug-outside-c-i-e-a cursor-in-echo-area
+ ))) ; let
+ ))
(defvar cl-debug-env nil) ;; defined in cl; non-nil when lexical env used.
(defun hif-infix-to-prefix (token-list)
"Convert list of tokens in infix into prefix list"
-; (message "hif-infix-to-prefix: %s" token-list)
+ ; (message "hif-infix-to-prefix: %s" token-list)
(if (= 1 (length token-list))
- (` (hif-lookup (quote (, (car token-list)))))
+ `(hif-lookup (quote ,(car token-list)))
(hif-parse-if-exp token-list))
)
(defun hif-factor ()
"Parse a factor: '!' factor | '(' expr ')' | 'defined(' id ')' | id."
(cond
- ((eq hif-token 'not)
- (hif-nexttoken)
- (list 'not (hif-factor)))
-
- ((eq hif-token 'lparen)
- (hif-nexttoken)
- (let ((result (hif-expr)))
- (if (not (eq hif-token 'rparen))
- (error "Bad token in parenthesized expression: %s" hif-token)
- (hif-nexttoken)
- result)))
-
- ((eq hif-token 'hif-defined)
- (hif-nexttoken)
- (if (not (eq hif-token 'lparen))
- (error "Error: expected \"(\" after \"defined\""))
- (hif-nexttoken)
- (let ((ident hif-token))
- (if (memq hif-token '(or and not hif-defined lparen rparen))
- (error "Error: unexpected token: %s" hif-token))
- (hif-nexttoken)
- (if (not (eq hif-token 'rparen))
- (error "Error: expected \")\" after identifier"))
- (hif-nexttoken)
- (` (hif-defined (quote (, ident))))
- ))
-
- (t ; identifier
- (let ((ident hif-token))
- (if (memq ident '(or and))
- (error "Error: missing identifier"))
+ ((eq hif-token 'not)
+ (hif-nexttoken)
+ (list 'not (hif-factor)))
+
+ ((eq hif-token 'lparen)
+ (hif-nexttoken)
+ (let ((result (hif-expr)))
+ (if (not (eq hif-token 'rparen))
+ (error "Bad token in parenthesized expression: %s" hif-token)
(hif-nexttoken)
- (` (hif-lookup (quote (, ident))))
- ))
- ))
+ result)))
+
+ ((eq hif-token 'hif-defined)
+ (hif-nexttoken)
+ (if (not (eq hif-token 'lparen))
+ (error "Error: expected \"(\" after \"defined\""))
+ (hif-nexttoken)
+ (let ((ident hif-token))
+ (if (memq hif-token '(or and not hif-defined lparen rparen))
+ (error "Error: unexpected token: %s" hif-token))
+ (hif-nexttoken)
+ (if (not (eq hif-token 'rparen))
+ (error "Error: expected \")\" after identifier"))
+ (hif-nexttoken)
+ `(hif-defined (quote ,ident))
+ ))
+
+ (t ; identifier
+ (let ((ident hif-token))
+ (if (memq ident '(or and))
+ (error "Error: missing identifier"))
+ (hif-nexttoken)
+ `(hif-lookup (quote ,ident))
+ ))
+ ))
(defun hif-mathify (val)
"Treat VAL as a number: if it's t or nil, use 1 or 0."
projects / emacs.git / commitdiff