commit 91932fff1ded8ed3b4d39dd06891f26960153b9e (HEAD, refs/remotes/origin/master) Author: Stefan Monnier Date: Thu Feb 23 22:39:53 2017 -0500 Use cl-print for Edebug and EIEIO * lisp/emacs-lisp/edebug.el (edebug-prin1-to-string): Use cl-print. (edebug-prin1, edebug-print): Remove. * lisp/emacs-lisp/eieio.el (object-print): Declare obsolete. (cl-print-object): Add a method for EIEIO objects. (eieio-edebug-prin1-to-string): Delete. (edebug-prin1-to-string): Don't advise any more. * lisp/emacs-lisp/eieio-datadebug.el (data-debug-insert-object-button): Replace `object-print' -> `cl-prin1-to-string'. diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index 267fc573d3..6013305562 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -398,31 +398,30 @@ Return the result of the last expression in BODY." (defun edebug-current-windows (which-windows) ;; Get either a full window configuration or some window information. (if (listp which-windows) - (mapcar (function (lambda (window) - (if (edebug-window-live-p window) - (list window - (window-buffer window) - (window-point window) - (window-start window) - (window-hscroll window))))) + (mapcar (lambda (window) + (if (edebug-window-live-p window) + (list window + (window-buffer window) + (window-point window) + (window-start window) + (window-hscroll window)))) which-windows) (current-window-configuration))) (defun edebug-set-windows (window-info) ;; Set either a full window configuration or some window information. (if (listp window-info) - (mapcar (function - (lambda (one-window-info) - (if one-window-info - (apply (function - (lambda (window buffer point start hscroll) - (if (edebug-window-live-p window) - (progn - (set-window-buffer window buffer) - (set-window-point window point) - (set-window-start window start) - (set-window-hscroll window hscroll))))) - one-window-info)))) + (mapcar (lambda (one-window-info) + (if one-window-info + (apply (function + (lambda (window buffer point start hscroll) + (if (edebug-window-live-p window) + (progn + (set-window-buffer window buffer) + (set-window-point window point) + (set-window-start window start) + (set-window-hscroll window hscroll))))) + one-window-info))) window-info) (set-window-configuration window-info))) @@ -658,7 +657,7 @@ Maybe clear the markers and delete the symbol's edebug property?" (progn ;; Instead of this, we could just find all contained forms. ;; (put (car entry) 'edebug nil) ; - ;; (mapcar 'edebug-clear-form-data-entry ; dangerous + ;; (mapcar #'edebug-clear-form-data-entry ; dangerous ;; (get (car entry) 'edebug-dependents)) ;; (set-marker (nth 1 entry) nil) ;; (set-marker (nth 2 entry) nil) @@ -945,7 +944,7 @@ circular objects. Let `read' read everything else." (let ((elements)) (while (not (eq 'rbracket (edebug-next-token-class))) (push (edebug-read-storing-offsets stream) elements)) - (apply 'vector (nreverse elements))) + (apply #'vector (nreverse elements))) (forward-char 1) ; skip \] )) @@ -988,7 +987,7 @@ circular objects. Let `read' read everything else." ;; Check if a dotted form is required. (if edebug-dotted-spec (edebug-no-match cursor "Dot expected.")) ;; Check if there is at least one more argument. - (if (edebug-empty-cursor cursor) (apply 'edebug-no-match cursor error)) + (if (edebug-empty-cursor cursor) (apply #'edebug-no-match cursor error)) ;; Return that top element. (edebug-top-element cursor)) @@ -1095,7 +1094,7 @@ circular objects. Let `read' read everything else." (setq result (edebug-read-and-maybe-wrap-form1)) nil))) (if no-match - (apply 'edebug-syntax-error no-match))) + (apply #'edebug-syntax-error no-match))) result)) @@ -1255,7 +1254,7 @@ expressions; a `progn' form will be returned enclosing these forms." (setq sexp new-sexp new-sexp (edebug-unwrap sexp))) (if (consp new-sexp) - (mapcar 'edebug-unwrap* new-sexp) + (mapcar #'edebug-unwrap* new-sexp) new-sexp))) @@ -1516,7 +1515,7 @@ expressions; a `progn' form will be returned enclosing these forms." (progn (if edebug-error-point (goto-char edebug-error-point)) - (apply 'edebug-syntax-error args)) + (apply #'edebug-syntax-error args)) (throw 'no-match args))) @@ -1712,7 +1711,7 @@ expressions; a `progn' form will be returned enclosing these forms." ;; Reset the cursor for the next match. (edebug-set-cursor cursor this-form this-offset)) ;; All failed. - (apply 'edebug-no-match cursor "Expected one of" original-specs)) + (apply #'edebug-no-match cursor "Expected one of" original-specs)) )) @@ -1738,9 +1737,9 @@ expressions; a `progn' form will be returned enclosing these forms." (edebug-match-&rest cursor (cons '&or - (mapcar (function (lambda (pair) - (vector (format ":%s" (car pair)) - (car (cdr pair))))) + (mapcar (lambda (pair) + (vector (format ":%s" (car pair)) + (car (cdr pair)))) specs)))) @@ -1785,7 +1784,7 @@ expressions; a `progn' form will be returned enclosing these forms." form (cdr (edebug-top-offset cursor))) (cdr specs)))) (edebug-move-cursor cursor) - (list (apply 'vector result))) + (list (apply #'vector result))) (edebug-no-match cursor "Expected" specs))) ((listp form) @@ -1812,7 +1811,7 @@ expressions; a `progn' form will be returned enclosing these forms." (edebug-match-specs cursor specs 'edebug-match-specs) (if (not (edebug-empty-cursor cursor)) (if edebug-best-error - (apply 'edebug-no-match cursor edebug-best-error) + (apply #'edebug-no-match cursor edebug-best-error) ;; A failed &rest or &optional spec may leave some args. (edebug-no-match cursor "Failed matching" specs) ))))) @@ -3377,10 +3376,10 @@ Return the result of the last expression." (message "%s: %s" (or (get (car value) 'error-message) (format "peculiar error (%s)" (car value))) - (mapconcat (function (lambda (edebug-arg) - ;; continuing after an error may - ;; complain about edebug-arg. why?? - (prin1-to-string edebug-arg))) + (mapconcat (lambda (edebug-arg) + ;; continuing after an error may + ;; complain about edebug-arg. why?? + (prin1-to-string edebug-arg)) (cdr value) ", "))) (defvar print-readably) ; defined by lemacs @@ -3411,11 +3410,9 @@ Return the result of the last expression." ;;; Read, Eval and Print -(defalias 'edebug-prin1 'prin1) -(defalias 'edebug-print 'print) -(defalias 'edebug-prin1-to-string 'prin1-to-string) -(defalias 'edebug-format 'format-message) -(defalias 'edebug-message 'message) +(defalias 'edebug-prin1-to-string #'cl-prin1-to-string) +(defalias 'edebug-format #'format-message) +(defalias 'edebug-message #'message) (defun edebug-eval-expression (expr) "Evaluate an expression in the outside environment. @@ -3656,7 +3653,7 @@ Options: ;; Don't do any edebug things now. (let ((edebug-execution-mode 'Go-nonstop) (edebug-trace nil)) - (mapcar 'edebug-safe-eval edebug-eval-list))) + (mapcar #'edebug-safe-eval edebug-eval-list))) (defun edebug-eval-display-list (eval-result-list) ;; Assumes edebug-eval-buffer exists. @@ -3804,7 +3801,7 @@ Otherwise call `debug' normally." ;; Otherwise call debug normally. ;; Still need to remove extraneous edebug calls from stack. - (apply 'debug arg-mode args) + (apply #'debug arg-mode args) )) @@ -3870,7 +3867,7 @@ You must include newlines in FMT to break lines, but one newline is appended." (setq truncate-lines t) (setq buf-window (selected-window)) (goto-char (point-max)) - (insert (apply 'edebug-format fmt args) "\n") + (insert (apply #'edebug-format fmt args) "\n") ;; Make it visible. (vertical-motion (- 1 (window-height))) (set-window-start buf-window (point)) @@ -3885,7 +3882,7 @@ You must include newlines in FMT to break lines, but one newline is appended." (defun edebug-trace (fmt &rest args) "Convenience call to `edebug-trace-display' using `edebug-trace-buffer'." - (apply 'edebug-trace-display edebug-trace-buffer fmt args)) + (apply #'edebug-trace-display edebug-trace-buffer fmt args)) ;;; Frequency count and coverage diff --git a/lisp/emacs-lisp/eieio-datadebug.el b/lisp/emacs-lisp/eieio-datadebug.el index 624757f229..8ef92df513 100644 --- a/lisp/emacs-lisp/eieio-datadebug.el +++ b/lisp/emacs-lisp/eieio-datadebug.el @@ -59,7 +59,7 @@ PREFIX is the text that precedes the button. PREBUTTONTEXT is some text between PREFIX and the object button." (let* ((start (point)) (end nil) - (str (object-print object)) + (str (cl-prin1-to-string object)) (class (eieio-object-class object)) (tip (format "Object %s\nClass: %S\nParent(s): %S\n%d slots" (eieio-object-name-string object) diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index 6872c0f448..1a6d5e9d7c 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -825,6 +825,7 @@ first and modify the returned object.") It is sometimes useful to put a summary of the object into the default # string when using EIEIO browsing tools. Implement this method to customize the summary." + (declare (obsolete cl-print-object "26.1")) (format "%S" this)) (cl-defmethod object-print ((this eieio-default-superclass) &rest strings) @@ -841,6 +842,12 @@ When passing in extra strings from child classes, always remember to prepend a space." (eieio-object-name this (apply #'concat strings))) + +(cl-defmethod cl-print-object ((object eieio-default-superclass) stream) + "Default printer for EIEIO objects." + ;; Fallback to the old `object-print'. + (princ (object-print object) stream)) + (defvar eieio-print-depth 0 "When printing, keep track of the current indentation depth.") @@ -945,27 +952,6 @@ of `eq'." ;; hyperlink from the constructor's docstring to see the type definition. (add-hook 'help-fns-describe-function-functions 'eieio-help-constructor) -;;; Interfacing with edebug -;; -(defun eieio-edebug-prin1-to-string (print-function object &optional noescape) - "Display EIEIO OBJECT in fancy format. - -Used as advice around `edebug-prin1-to-string', held in the -variable PRINT-FUNCTION. Optional argument NOESCAPE is passed to -`prin1-to-string' when appropriate." - (cond ((eieio--class-p object) (eieio--class-print-name object)) - ((eieio-object-p object) (object-print object)) - ((and (listp object) (or (eieio--class-p (car object)) - (eieio-object-p (car object)))) - (concat "(" (mapconcat - (lambda (x) (eieio-edebug-prin1-to-string print-function x)) - object " ") - ")")) - (t (funcall print-function object noescape)))) - -(advice-add 'edebug-prin1-to-string - :around #'eieio-edebug-prin1-to-string) - (provide 'eieio) ;;; eieio ends here commit f1f17265c9b029929a2f52d206cff0e943690847 Author: Stefan Monnier Date: Thu Feb 23 21:19:20 2017 -0500 Fix left over uses of `call-next-method' * lisp/cedet/semantic/db-global.el (object-print): * lisp/cedet/semantic/db.el (object-print): Use `cl-call-next-method'. diff --git a/lisp/cedet/semantic/db-global.el b/lisp/cedet/semantic/db-global.el index 8cb9dab5aa..61af619b29 100644 --- a/lisp/cedet/semantic/db-global.el +++ b/lisp/cedet/semantic/db-global.el @@ -115,7 +115,7 @@ if optional DONT-ERR-IF-NOT-AVAILABLE is non-nil; else throw an error." (cl-defmethod object-print ((obj semanticdb-table-global) &rest strings) "Pretty printer extension for `semanticdb-table-global'. Adds the number of tags in this file to the object print name." - (apply 'call-next-method obj (cons " (proxy)" strings))) + (apply #'cl-call-next-method obj (cons " (proxy)" strings))) (cl-defmethod semanticdb-equivalent-mode ((table semanticdb-table-global) &optional buffer) "Return t, pretend that this table's mode is equivalent to BUFFER. diff --git a/lisp/cedet/semantic/db.el b/lisp/cedet/semantic/db.el index d9eef32616..0ba9f2f9c6 100644 --- a/lisp/cedet/semantic/db.el +++ b/lisp/cedet/semantic/db.el @@ -180,7 +180,7 @@ Adds the number of tags in this file to the object print name." ;; Else, add a tags quantifier. (cl-call-next-method obj (format " (%d tags)" (length (semanticdb-get-tags obj)))) ;; Pass through. - (apply 'call-next-method obj strings) + (apply #'cl-call-next-method obj strings) )) ;;; Index Cache @@ -324,9 +324,10 @@ If OBJ's file is not loaded, read it in first." (cl-defmethod object-print ((obj semanticdb-table) &rest strings) "Pretty printer extension for `semanticdb-table'. Adds the number of tags in this file to the object print name." - (apply 'call-next-method obj - (cons (format " (%d tags)" (length (semanticdb-get-tags obj))) - (cons (if (oref obj dirty) ", DIRTY" "") strings)))) + (apply #'cl-call-next-method obj + (format " (%d tags)" (length (semanticdb-get-tags obj))) + (if (oref obj dirty) ", DIRTY" "") + strings)) ;;; DATABASE BASE CLASS ;; @@ -382,13 +383,13 @@ where it may need to resynchronize with some persistent storage." (cl-defmethod object-print ((obj semanticdb-project-database) &rest strings) "Pretty printer extension for `semanticdb-project-database'. Adds the number of tables in this file to the object print name." - (apply 'call-next-method obj - (cons (format " (%d tables%s)" - (length (semanticdb-get-database-tables obj)) - (if (semanticdb-dirty-p obj) - " DIRTY" "") - ) - strings))) + (apply #'cl-call-next-method obj + (format " (%d tables%s)" + (length (semanticdb-get-database-tables obj)) + (if (semanticdb-dirty-p obj) + " DIRTY" "") + ) + strings)) (cl-defmethod semanticdb-create-database ((dbc (subclass semanticdb-project-database)) directory) "Create a new semantic database of class DBC for DIRECTORY and return it. commit dee8674414fae2323fd9cbf05aa762e72fa575e5 Author: Stefan Monnier Date: Thu Feb 23 21:17:04 2017 -0500 Minor redisplay optimisations * src/frame.c (Ficonify_frame): No need to redisplay everything. * src/xdisp.c (overlay_arrows_changed_p): Add `set_redisplay' argument. (redisplay_internal): Use it to avoid redisplaying everything. (try_window_id): Use it keep the same behavior as before. diff --git a/src/frame.c b/src/frame.c index d0f653fc76..5e1e2f1990 100644 --- a/src/frame.c +++ b/src/frame.c @@ -2156,9 +2156,6 @@ If omitted, FRAME defaults to the currently selected frame. */) #endif } - /* Make menu bar update for the Buffers and Frames menus. */ - windows_or_buffers_changed = 17; - return Qnil; } diff --git a/src/xdisp.c b/src/xdisp.c index e59934d2d5..b0ff627c70 100644 --- a/src/xdisp.c +++ b/src/xdisp.c @@ -13336,7 +13336,7 @@ overlay_arrow_in_current_buffer_p (void) has changed. */ static bool -overlay_arrows_changed_p (void) +overlay_arrows_changed_p (bool set_redisplay) { Lisp_Object vlist; @@ -13356,7 +13356,12 @@ overlay_arrows_changed_p (void) Fget (var, Qlast_arrow_position)) || ! (pstr = overlay_arrow_string_or_property (var), EQ (pstr, Fget (var, Qlast_arrow_string)))) - return true; + { + if (set_redisplay) + bset_redisplay (XMARKER (val)->buffer); + else + return true; + } } return false; } @@ -13781,10 +13786,9 @@ redisplay_internal (void) /* If specs for an arrow have changed, do thorough redisplay to ensure we remove any arrow that should no longer exist. */ - if (overlay_arrows_changed_p ()) - /* Apparently, this is the only case where we update other windows, - without updating other mode-lines. */ - windows_or_buffers_changed = 49; + /* Apparently, this is the only case where we update other windows, + without updating other mode-lines. */ + overlay_arrows_changed_p (true); consider_all_windows_p = (update_mode_lines || windows_or_buffers_changed); @@ -18282,7 +18286,7 @@ try_window_id (struct window *w) /* Can't use this if overlay arrow position and/or string have changed. */ - if (overlay_arrows_changed_p ()) + if (overlay_arrows_changed_p (false)) GIVE_UP (12); /* When word-wrap is on, adding a space to the first word of a commit 407e650413c0296f5873a1399c2306b25f81f310 Author: Stefan Monnier Date: Thu Feb 23 21:06:54 2017 -0500 * lisp/emacs-lisp/cl-print.el: New file * lisp/emacs-lisp/nadvice.el (advice--where): New function. (advice--make-docstring): Use it. * src/print.c (print_number_index): Don't declare here any more. (Fprint_preprocess): New function. * test/lisp/emacs-lisp/cl-print-tests.el: New file. diff --git a/lisp/emacs-lisp/cl-print.el b/lisp/emacs-lisp/cl-print.el new file mode 100644 index 0000000000..b4ceefb9b1 --- /dev/null +++ b/lisp/emacs-lisp/cl-print.el @@ -0,0 +1,196 @@ +;;; cl-print.el --- CL-style generic printer facilies -*- lexical-binding: t; -*- + +;; Copyright (C) 2017 Free Software Foundation, Inc. + +;; Author: Stefan Monnier +;; Keywords: +;; Version: 1.0 +;; Package-Requires: ((emacs "25")) + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;; Customizable print facility. +;; +;; The heart of it is the generic function `cl-print-object' to which you +;; can add any method you like. +;; +;; The main entry point is `cl-prin1'. + +;;; Code: + +(defvar cl-print-readably nil + "If non-nil, try and make sure the result can be `read'.") + +(defvar cl-print--number-table nil) + +;;;###autoload +(cl-defgeneric cl-print-object (object stream) + "Dispatcher to print OBJECT on STREAM according to its type. +You can add methods to it to customize the output. +But if you just want to print something, don't call this directly: +call other entry points instead, such as `cl-prin1'." + ;; This delegates to the C printer. The C printer will not call us back, so + ;; we should only use it for objects which don't have nesting. + (prin1 object stream)) + +(cl-defmethod cl-print-object ((object cons) stream) + (let ((car (pop object))) + (if (and (memq car '(\, quote \` \,@ \,.)) + (consp object) + (null (cdr object))) + (progn + (princ (if (eq car 'quote) '\' car) stream) + (cl-print-object (car object) stream)) + (princ "(" stream) + (cl-print-object car stream) + (while (and (consp object) + (not (and cl-print--number-table + (numberp (gethash object cl-print--number-table))))) + (princ " " stream) + (cl-print-object (pop object) stream)) + (when object + (princ " . " stream) (cl-print-object object stream)) + (princ ")" stream)))) + +(cl-defmethod cl-print-object ((object vector) stream) + (princ "[" stream) + (dotimes (i (length object)) + (unless (zerop i) (princ " " stream)) + (cl-print-object (aref object i) stream)) + (princ "]" stream)) + +(cl-defmethod cl-print-object ((object compiled-function) stream) + (princ "# >" stream)) + +;; This belongs in nadvice.el, of course, but some load-ordering issues make it +;; complicated: cl-generic uses macros from cl-macs and cl-macs uses advice-add +;; from nadvice, so nadvice needs to be loaded before cl-generic and hence +;; can't use cl-defmethod. +(cl-defmethod cl-print-object :extra "nadvice" + ((object compiled-function) stream) + (if (not (advice--p object)) + (cl-call-next-method) + (princ "#" stream))) + +(cl-defmethod cl-print-object ((object cl-structure-object) stream) + (princ "#s(" stream) + (let* ((class (symbol-value (aref object 0))) + (slots (cl--struct-class-slots class))) + (princ (cl--struct-class-name class) stream) + (dotimes (i (length slots)) + (let ((slot (aref slots i))) + (princ " :" stream) + (princ (cl--slot-descriptor-name slot) stream) + (princ " " stream) + (cl-print-object (aref object (1+ i)) stream)))) + (princ ")" stream)) + +;;; Circularity and sharing. + +;; I don't try to support the `print-continuous-numbering', because +;; I think it's ill defined anyway: if an object appears only once in each call +;; its sharing can't be properly preserved! + +(cl-defmethod cl-print-object :around (object stream) + ;; FIXME: Only put such an :around method on types where it's relevant. + (let ((n (if cl-print--number-table (gethash object cl-print--number-table)))) + (if (not (numberp n)) + (cl-call-next-method) + (if (> n 0) + ;; Already printed. Just print a reference. + (progn (princ "#" stream) (princ n stream) (princ "#" stream)) + (puthash object (- n) cl-print--number-table) + (princ "#" stream) (princ (- n) stream) (princ "=" stream) + (cl-call-next-method))))) + +(defvar cl-print--number-index nil) + +(defun cl-print--find-sharing (object table) + ;; Avoid recursion: not only because it's too easy to bump into + ;; `max-lisp-eval-depth', but also because function calls are fairly slow. + ;; At first, I thought using a list for our stack would cause too much + ;; garbage to generated, but I didn't notice any such problem in practice. + ;; I experimented with using an array instead, but the result was slightly + ;; slower and the reduction in GC activity was less than 1% on my test. + (let ((stack (list object))) + (while stack + (let ((object (pop stack))) + (unless + ;; Skip objects which don't have identity! + (or (floatp object) (numberp object) + (null object) (if (symbolp object) (intern-soft object))) + (let ((n (gethash object table))) + (cond + ((numberp n)) ;All done. + (n ;Already seen, but only once. + (let ((n (1+ cl-print--number-index))) + (setq cl-print--number-index n) + (puthash object (- n) table))) + (t + (puthash object t table) + (pcase object + (`(,car . ,cdr) + (push cdr stack) + (push car stack)) + ((pred stringp) + ;; We presumably won't print its text-properties. + nil) + ((or (pred arrayp) (pred byte-code-function-p)) + ;; FIXME: Inefficient for char-tables! + (dotimes (i (length object)) + (push (aref object i) stack)))))))))))) + +(defun cl-print--preprocess (object) + (let ((print-number-table (make-hash-table :test 'eq :rehash-size 2.0))) + (if (fboundp 'print--preprocess) + ;; Use the predefined C version if available. + (print--preprocess object) ;Fill print-number-table! + (let ((cl-print--number-index 0)) + (cl-print--find-sharing object print-number-table))) + print-number-table)) + +;;;###autoload +(defun cl-prin1 (object &optional stream) + (cond + (cl-print-readably (prin1 object stream)) + ((not print-circle) (cl-print-object object stream)) + (t + (let ((cl-print--number-table (cl-print--preprocess object))) + (cl-print-object object stream))))) + +;;;###autoload +(defun cl-prin1-to-string (object) + (with-temp-buffer + (cl-prin1 object (current-buffer)) + (buffer-string))) + +(provide 'cl-print) +;;; cl-print.el ends here diff --git a/lisp/emacs-lisp/nadvice.el b/lisp/emacs-lisp/nadvice.el index 5a100b790f..fd1cd2c7aa 100644 --- a/lisp/emacs-lisp/nadvice.el +++ b/lisp/emacs-lisp/nadvice.el @@ -72,6 +72,13 @@ Each element has the form (WHERE BYTECODE STACK) where: (setq f (advice--cdr f))) f) +(defun advice--where (f) + (let ((bytecode (aref f 1)) + (where nil)) + (dolist (elem advice--where-alist) + (if (eq bytecode (cadr elem)) (setq where (car elem)))) + where)) + (defun advice--make-docstring (function) "Build the raw docstring for FUNCTION, presumably advised." (let* ((flist (indirect-function function)) @@ -79,16 +86,13 @@ Each element has the form (WHERE BYTECODE STACK) where: (docstring nil)) (if (eq 'macro (car-safe flist)) (setq flist (cdr flist))) (while (advice--p flist) - (let ((bytecode (aref flist 1)) - (doc (aref flist 4)) - (where nil)) + (let ((doc (aref flist 4)) + (where (advice--where flist))) ;; Hack attack! For advices installed before calling ;; Snarf-documentation, the integer offset into the DOC file will not ;; be installed in the "core unadvised function" but in the advice ;; object instead! So here we try to undo the damage. (if (integerp doc) (setq docfun flist)) - (dolist (elem advice--where-alist) - (if (eq bytecode (cadr elem)) (setq where (car elem)))) (setq docstring (concat docstring @@ -502,6 +506,10 @@ of the piece of advice." (setq frame2 (backtrace-frame i #'called-interactively-p)) ;; (message "Advice Frame %d = %S" i frame2) (setq i (1+ i))))) + ;; FIXME: Adjust this for the new :filter advices, since they use `funcall' + ;; rather than `apply'. + ;; FIXME: Somehow this doesn't work on (advice-add :before + ;; 'call-interactively #'ignore), see bug#3984. (when (and (eq (nth 1 frame2) 'apply) (progn (funcall get-next-frame) diff --git a/src/print.c b/src/print.c index 8c4bb24555..d8acf83874 100644 --- a/src/print.c +++ b/src/print.c @@ -640,7 +640,7 @@ is used instead. */) return object; } -/* a buffer which is used to hold output being built by prin1-to-string */ +/* A buffer which is used to hold output being built by prin1-to-string. */ Lisp_Object Vprin1_to_string_buffer; DEFUN ("prin1-to-string", Fprin1_to_string, Sprin1_to_string, 1, 2, 0, @@ -1140,14 +1140,14 @@ print (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) print_object (obj, printcharfun, escapeflag); } -#define PRINT_CIRCLE_CANDIDATE_P(obj) \ - (STRINGP (obj) || CONSP (obj) \ - || (VECTORLIKEP (obj) \ - && (VECTORP (obj) || COMPILEDP (obj) \ - || CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj) \ - || HASH_TABLE_P (obj) || FONTP (obj))) \ - || (! NILP (Vprint_gensym) \ - && SYMBOLP (obj) \ +#define PRINT_CIRCLE_CANDIDATE_P(obj) \ + (STRINGP (obj) || CONSP (obj) \ + || (VECTORLIKEP (obj) \ + && (VECTORP (obj) || COMPILEDP (obj) \ + || CHAR_TABLE_P (obj) || SUB_CHAR_TABLE_P (obj) \ + || HASH_TABLE_P (obj) || FONTP (obj))) \ + || (! NILP (Vprint_gensym) \ + && SYMBOLP (obj) \ && !SYMBOL_INTERNED_P (obj))) /* Construct Vprint_number_table according to the structure of OBJ. @@ -1260,6 +1260,16 @@ print_preprocess (Lisp_Object obj) print_depth--; } +DEFUN ("print--preprocess", Fprint_preprocess, Sprint_preprocess, 1, 1, 0, + doc: /* Extract sharing info from OBJECT needed to print it. +Fills `print-number-table'. */) + (Lisp_Object object) +{ + print_number_index = 0; + print_preprocess (object); + return Qnil; +} + static void print_preprocess_string (INTERVAL interval, Lisp_Object arg) { @@ -1537,7 +1547,8 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) size_byte = SBYTES (name); - if (! NILP (Vprint_gensym) && !SYMBOL_INTERNED_P (obj)) + if (! NILP (Vprint_gensym) + && !SYMBOL_INTERNED_IN_INITIAL_OBARRAY_P (obj)) print_c_string ("#:", printcharfun); else if (size_byte == 0) { @@ -2344,6 +2355,7 @@ priorities. */); defsubr (&Sterpri); defsubr (&Swrite_char); defsubr (&Sredirect_debugging_output); + defsubr (&Sprint_preprocess); DEFSYM (Qprint_escape_newlines, "print-escape-newlines"); DEFSYM (Qprint_escape_multibyte, "print-escape-multibyte"); diff --git a/test/lisp/emacs-lisp/cl-print-tests.el b/test/lisp/emacs-lisp/cl-print-tests.el new file mode 100644 index 0000000000..cbc79b0e64 --- /dev/null +++ b/test/lisp/emacs-lisp/cl-print-tests.el @@ -0,0 +1,40 @@ +;;; cl-print-tests.el --- Test suite for the cl-print facility. -*- lexical-binding:t -*- + +;; Copyright (C) 2017 Free Software Foundation, Inc. + +;; This file is part of GNU Emacs. + +;; GNU Emacs is free software: you can redistribute it and/or modify +;; it under the terms of the GNU General Public License as published by +;; the Free Software Foundation, either version 3 of the License, or +;; (at your option) any later version. + +;; GNU Emacs is distributed in the hope that it will be useful, +;; but WITHOUT ANY WARRANTY; without even the implied warranty of +;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the +;; GNU General Public License for more details. + +;; You should have received a copy of the GNU General Public License +;; along with GNU Emacs. If not, see . + +;;; Commentary: + +;;; Code: + +(require 'ert) + +(cl-defstruct cl-print--test a b) + +(ert-deftest cl-print-tests-1 () + "Test cl-print code." + (let ((x (make-cl-print--test :a 1 :b 2))) + (let ((print-circle nil)) + (should (equal (cl-prin1-to-string `((x . ,x) (y . ,x))) + "((x . #s(cl-print--test :a 1 :b 2)) (y . #s(cl-print--test :a 1 :b 2)))"))) + (let ((print-circle t)) + (should (equal (cl-prin1-to-string `((x . ,x) (y . ,x))) + "((x . #1=#s(cl-print--test :a 1 :b 2)) (y . #1#))"))) + (should (string-match "\\`#\\'" + (cl-prin1-to-string (symbol-function #'caar)))))) + +;;; cl-print-tests.el ends here. commit f6d2ba74f80b9a055a3d8072d49475aec45c2dbe Author: Peder O. Klingenberg Date: Thu Feb 23 20:27:57 2017 -0500 Make calc's least common multiple positive (bug#25255) * lisp/calc/calc-comb.el (calcFunc-lcm): Return absolute value. * doc/misc/calc.texi (Combinatorial Functions): Update for the above. diff --git a/doc/misc/calc.texi b/doc/misc/calc.texi index baf46f7170..7bd060189c 100644 --- a/doc/misc/calc.texi +++ b/doc/misc/calc.texi @@ -19111,8 +19111,8 @@ the operation is left in symbolic form. @tindex lcm The @kbd{k l} (@code{calc-lcm}) [@code{lcm}] command computes the Least Common Multiple of two integers or fractions. The product of -the LCM and GCD of two numbers is equal to the product of the -numbers. +the LCM and GCD of two numbers is equal to the absolute value of the +product of the numbers. @kindex k E @pindex calc-extended-gcd diff --git a/lisp/calc/calc-comb.el b/lisp/calc/calc-comb.el index bc1ac315a0..c84ff23685 100644 --- a/lisp/calc/calc-comb.el +++ b/lisp/calc/calc-comb.el @@ -260,7 +260,7 @@ (defun calcFunc-lcm (a b) (let ((g (calcFunc-gcd a b))) (if (Math-numberp g) - (math-div (math-mul a b) g) + (math-div (math-abs (math-mul a b)) g) (list 'calcFunc-lcm a b)))) (defun calcFunc-egcd (a b) ; Knuth section 4.5.2 commit 8b912ab47bc91f54565f127abf24c97e5d46a1ba Author: Gemini Lasswell Date: Thu Feb 16 22:08:03 2017 -0800 Support read syntax for circular objects in Edebug (Bug#23660) * lisp/emacs-lisp/edebug.el (edebug-read-special): New name for edebug-read-function. Handle the read syntax for circular objects. (edebug-read-objects): New variable. (edebug-read-and-maybe-wrap-form1): Reset edebug-read-objects. * src/lread.c (Fsubstitute_object_in_subtree): Make substitute_object_in_subtree into a Lisp primitive. diff --git a/lisp/emacs-lisp/edebug.el b/lisp/emacs-lisp/edebug.el index a8838046a4..267fc573d3 100644 --- a/lisp/emacs-lisp/edebug.el +++ b/lisp/emacs-lisp/edebug.el @@ -755,6 +755,11 @@ Maybe clear the markers and delete the symbol's edebug property?" (defvar edebug-offsets-stack nil) (defvar edebug-current-offset nil) ; Top of the stack, for convenience. +;; The association list of objects read with the #n=object form. +;; Each member of the list has the form (n . object), and is used to +;; look up the object for the corresponding #n# construct. +(defvar edebug-read-objects nil) + ;; We must store whether we just read a list with a dotted form that ;; is itself a list. This structure will be condensed, so the offsets ;; must also be condensed. @@ -826,7 +831,7 @@ Maybe clear the markers and delete the symbol's edebug property?" (backquote . edebug-read-backquote) (comma . edebug-read-comma) (lbracket . edebug-read-vector) - (hash . edebug-read-function) + (hash . edebug-read-special) )) (defun edebug-read-storing-offsets (stream) @@ -872,17 +877,47 @@ Maybe clear the markers and delete the symbol's edebug property?" (edebug-storing-offsets opoint symbol) (edebug-read-storing-offsets stream))))) -(defun edebug-read-function (stream) - ;; Turn #'thing into (function thing) - (forward-char 1) - (cond ((eq ?\' (following-char)) - (forward-char 1) - (list - (edebug-storing-offsets (- (point) 2) 'function) - (edebug-read-storing-offsets stream))) - (t - (backward-char 1) - (read stream)))) +(defun edebug-read-special (stream) + "Read from STREAM a Lisp object beginning with #. +Turn #'thing into (function thing) and handle the read syntax for +circular objects. Let `read' read everything else." + (catch 'return + (forward-char 1) + (let ((start (point))) + (cond + ((eq ?\' (following-char)) + (forward-char 1) + (throw 'return + (list + (edebug-storing-offsets (- (point) 2) 'function) + (edebug-read-storing-offsets stream)))) + ((and (>= (following-char) ?0) (<= (following-char) ?9)) + (while (and (>= (following-char) ?0) (<= (following-char) ?9)) + (forward-char 1)) + (let ((n (string-to-number (buffer-substring start (point))))) + (when (and read-circle + (<= n most-positive-fixnum)) + (cond + ((eq ?= (following-char)) + ;; Make a placeholder for #n# to use temporarily. + (let* ((placeholder (cons nil nil)) + (elem (cons n placeholder))) + (push elem edebug-read-objects) + ;; Read the object and then replace the placeholder + ;; with the object itself, wherever it occurs. + (forward-char 1) + (let ((obj (edebug-read-storing-offsets stream))) + (substitute-object-in-subtree obj placeholder) + (throw 'return (setf (cdr elem) obj))))) + ((eq ?# (following-char)) + ;; #n# returns a previously read object. + (let ((elem (assq n edebug-read-objects))) + (when (consp elem) + (forward-char 1) + (throw 'return (cdr elem)))))))))) + ;; Let read handle errors, radix notation, and anything else. + (goto-char (1- start)) + (read stream)))) (defun edebug-read-list (stream) (forward-char 1) ; skip \( @@ -1074,6 +1109,7 @@ Maybe clear the markers and delete the symbol's edebug property?" edebug-offsets edebug-offsets-stack edebug-current-offset ; reset to nil + edebug-read-objects ) (save-excursion (if (and (eq 'lparen (edebug-next-token-class)) diff --git a/src/lread.c b/src/lread.c index 094aa628ee..1b154b7326 100644 --- a/src/lread.c +++ b/src/lread.c @@ -558,8 +558,6 @@ static Lisp_Object read_vector (Lisp_Object, bool); static Lisp_Object substitute_object_recurse (Lisp_Object, Lisp_Object, Lisp_Object); -static void substitute_object_in_subtree (Lisp_Object, - Lisp_Object); static void substitute_in_interval (INTERVAL, Lisp_Object); @@ -2957,7 +2955,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) tem = read0 (readcharfun); /* Now put it everywhere the placeholder was... */ - substitute_object_in_subtree (tem, placeholder); + Fsubstitute_object_in_subtree (tem, placeholder); /* ...and #n# will use the real value from now on. */ Fsetcdr (cell, tem); @@ -3326,8 +3324,10 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) /* List of nodes we've seen during substitute_object_in_subtree. */ static Lisp_Object seen_list; -static void -substitute_object_in_subtree (Lisp_Object object, Lisp_Object placeholder) +DEFUN ("substitute-object-in-subtree", Fsubstitute_object_in_subtree, + Ssubstitute_object_in_subtree, 2, 2, 0, + doc: /* Replace every reference to PLACEHOLDER in OBJECT with OBJECT. */) + (Lisp_Object object, Lisp_Object placeholder) { Lisp_Object check_object; @@ -3345,6 +3345,7 @@ substitute_object_in_subtree (Lisp_Object object, Lisp_Object placeholder) original. */ if (!EQ (check_object, object)) error ("Unexpected mutation error in reader"); + return Qnil; } /* Feval doesn't get called from here, so no gc protection is needed. */ @@ -4548,6 +4549,7 @@ syms_of_lread (void) { defsubr (&Sread); defsubr (&Sread_from_string); + defsubr (&Ssubstitute_object_in_subtree); defsubr (&Sintern); defsubr (&Sintern_soft); defsubr (&Sunintern); commit ba6c382404a9fe598be72e64beb21a90161ebb91 Author: Lixin Chin Date: Thu Feb 23 19:04:27 2017 -0500 Add Conference to the list of valid bibtex entry types * lisp/textmodes/bibtex.el (bibtex-BibTeX-entry-alist): Add Conference as a duplicate of InProceedings. (Bug#25143) Copyright-paperwork-exempt: yes diff --git a/lisp/textmodes/bibtex.el b/lisp/textmodes/bibtex.el index 6cbdc1efd8..2128e50797 100644 --- a/lisp/textmodes/bibtex.el +++ b/lisp/textmodes/bibtex.el @@ -317,6 +317,20 @@ If parsing fails, try to set this variable to nil." ("organization" "Sponsoring organization of the conference") ("publisher" "Publishing company, its location") ("note"))) + ("Conference" "Article in Conference Proceedings" ; same as InProceedings + (("author") + ("title" "Title of the article in proceedings (BibTeX converts it to lowercase)")) + (("booktitle" "Name of the conference proceedings") + ("year")) + (("editor") + ("volume" "Volume of the conference proceedings in the series") + ("number" "Number of the conference proceedings in a small series (overwritten by volume)") + ("series" "Series in which the conference proceedings appeared") + ("pages" "Pages in the conference proceedings") + ("month") ("address") + ("organization" "Sponsoring organization of the conference") + ("publisher" "Publishing company, its location") + ("note"))) ("InCollection" "Article in a Collection" (("author") ("title" "Title of the article in book (BibTeX converts it to lowercase)") @@ -444,7 +458,7 @@ which is called to determine the initial content of the field. ALTERNATIVE if non-nil is an integer that numbers sets of alternatives, starting from zero." :group 'BibTeX - :version "24.1" + :version "26.1" ; add Conference :type 'bibtex-entry-alist) (put 'bibtex-BibTeX-entry-alist 'risky-local-variable t) commit 581c4d1f1c2a6415ded31e03540b93b195056b96 Author: Glenn Morris Date: Thu Feb 23 17:12:49 2017 -0500 * lisp/comint.el (comint-password-prompt-regexp): Add SUDO. (Bug#24817) diff --git a/lisp/comint.el b/lisp/comint.el index 830f4ca88f..7bac30598f 100644 --- a/lisp/comint.el +++ b/lisp/comint.el @@ -356,7 +356,7 @@ This variable is buffer-local." (regexp-opt '("Enter" "enter" "Enter same" "enter same" "Enter the" "enter the" "Old" "old" "New" "new" "'s" "login" - "Kerberos" "CVS" "UNIX" " SMB" "LDAP" "PEM" + "Kerberos" "CVS" "UNIX" " SMB" "LDAP" "PEM" "SUDO" "[sudo]" "Repeat" "Bad" "Retype") t) " +\\)" commit 16efea3a883ebf633946ee9b9d0681eb55437878 Author: Glenn Morris Date: Thu Feb 23 13:22:31 2017 -0500 Small dunnet score file improvements * lisp/play/dunnet.el (dun-log-file): Switch to per-user default. (dun-do-logfile): Handle non-existing score file. diff --git a/lisp/play/dunnet.el b/lisp/play/dunnet.el index ae31dc56ff..f0a1cf1200 100644 --- a/lisp/play/dunnet.el +++ b/lisp/play/dunnet.el @@ -27,10 +27,6 @@ ;; This game can be run in batch mode. To do this, use: ;; emacs -batch -l dunnet -;;; !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! -;;; The log file should be set for your system, and it must -;;; be writable by all. - ;;; Code: (defgroup dunnet nil @@ -38,8 +34,13 @@ :prefix "dun-" :group 'games) -(defcustom dun-log-file "/usr/local/dunnet.score" +;; Cf gamegrid. dunnet normally runs in batch mode, where +;; locate-user-emacs-file doesn't create directories. +(defcustom dun-log-file (expand-file-name "dunnet-scores" + (let (noninteractive) + (locate-user-emacs-file "games/"))) "Name of file to store score information for dunnet." + :version "26.1" :type 'file :group 'dunnet) @@ -3068,11 +3069,15 @@ File not found"))) (setq dun-room 0))))) +;; See gamegrid-add-score; but that only handles a single integer score. (defun dun-do-logfile (type how) (let (ferror) (with-temp-buffer (condition-case err - (insert-file-contents dun-log-file) + (if (file-exists-p dun-log-file) + (insert-file-contents dun-log-file) + (let ((dir (file-name-directory dun-log-file))) + (if dir (make-directory dir t)))) (error (setq ferror t) (dun-mprincl (error-message-string err)))) commit e50317fb7282041eb972356e5d644112112ab9df Author: Glenn Morris Date: Thu Feb 23 13:20:48 2017 -0500 * lisp/play/dunnet.el (dun-help): Doc fix. diff --git a/lisp/play/dunnet.el b/lisp/play/dunnet.el index 1483d2c01a..ae31dc56ff 100644 --- a/lisp/play/dunnet.el +++ b/lisp/play/dunnet.el @@ -1987,7 +1987,7 @@ or more clues in here): If this happens, your score will decrease, and in many cases you can never get credit for it again. -- You can save your game with the ‘save’ command, and use restore it +- You can save your game with the ‘save’ command, and restore it with the ‘restore’ command. - There are no limits on lengths of object names. commit 6f225b7fdfb47b09ee9a9b881740e2090acdf862 Author: Mark Oteiza Date: Thu Feb 23 13:14:44 2017 -0500 Declare dun-line and dun-line-list Previously, there were free variables 'line' and 'line-list'. * lisp/play/dunnet.el (dun-line, dun-line-list): New variables. (dun-press, dun-vparse, dun-parse2, dun-unix-parse, dun-batch-parse): (dun-batch-parse2, dun-batch-loop, dun-batch-dos-interface): (dun-batch-unix-interface): Use them. diff --git a/lisp/play/dunnet.el b/lisp/play/dunnet.el index f553c16d15..1483d2c01a 100644 --- a/lisp/play/dunnet.el +++ b/lisp/play/dunnet.el @@ -1135,6 +1135,9 @@ treasures for points?" "4" "four") (defconst dun-combination (prin1-to-string (+ 100 (random 899)))) +(defvar dun-line nil) +(defvar dun-line-list nil) + ;;;; Mode definitions for interactive mode @@ -1924,7 +1927,7 @@ disk bursts into flames, and disintegrates.") (member objnum (nth dun-current-room dun-room-silents)))) (dun-mprincl "I don't see that here.")) ((not (member objnum (list obj-button obj-switch))) - (dun-mprincl "You can't " (car line-list) " that.")) + (dun-mprincl "You can't " (car dun-line-list) " that.")) ((= objnum obj-button) (dun-mprincl "As you press the button, you notice a passageway open up, but @@ -2235,13 +2238,13 @@ for a moment, then straighten yourself up. (defun dun-vparse (ignore verblist line) (dun-mprinc "\n") - (setq line-list (dun-listify-string (concat line " "))) - (dun-doverb ignore verblist (car line-list) (cdr line-list))) + (setq dun-line-list (dun-listify-string (concat line " "))) + (dun-doverb ignore verblist (car dun-line-list) (cdr dun-line-list))) (defun dun-parse2 (ignore verblist line) (dun-mprinc "\n") - (setq line-list (dun-listify-string2 (concat line " "))) - (dun-doverb ignore verblist (car line-list) (cdr line-list))) + (setq dun-line-list (dun-listify-string2 (concat line " "))) + (dun-doverb ignore verblist (car dun-line-list) (cdr dun-line-list))) ;;; Read a line, in window mode @@ -2397,13 +2400,13 @@ for a moment, then straighten yourself up. (if (and (not (= beg (point))) (string= "$" (buffer-substring (- beg 2) (- beg 1)))) (progn - (setq line (downcase (buffer-substring beg (point)))) - (princ line) - (if (eq (dun-parse2 nil dun-unix-verbs line) -1) + (setq dun-line (downcase (buffer-substring beg (point)))) + (princ dun-line) + (if (eq (dun-parse2 nil dun-unix-verbs dun-line) -1) (progn - (if (setq esign (string-match "=" line)) - (dun-doassign line esign) - (dun-mprinc (car line-list)) + (if (setq esign (string-match "=" dun-line)) + (dun-doassign dun-line esign) + (dun-mprinc (car dun-line-list)) (dun-mprincl ": not found."))))) (goto-char (point-max)) (dun-mprinc "\n")) @@ -3111,12 +3114,12 @@ File not found"))) (send-string-to-terminal "\n")) (defun dun-batch-parse (ignore verblist line) - (setq line-list (dun-listify-string (concat line " "))) - (dun-doverb ignore verblist (car line-list) (cdr line-list))) + (setq dun-line-list (dun-listify-string (concat line " "))) + (dun-doverb ignore verblist (car dun-line-list) (cdr dun-line-list))) (defun dun-batch-parse2 (ignore verblist line) - (setq line-list (dun-listify-string2 (concat line " "))) - (dun-doverb ignore verblist (car line-list) (cdr line-list))) + (setq dun-line-list (dun-listify-string2 (concat line " "))) + (dun-doverb ignore verblist (car dun-line-list) (cdr dun-line-list))) (defun dun-batch-read-line () (read-from-minibuffer "" nil dungeon-batch-map)) @@ -3133,8 +3136,8 @@ File not found"))) (dun-describe-room dun-current-room) (setq dun-room dun-current-room))) (dun-mprinc ">") - (setq line (downcase (dun-read-line))) - (if (eq (dun-vparse dun-ignore dun-verblist line) -1) + (setq dun-line (downcase (dun-read-line))) + (if (eq (dun-vparse dun-ignore dun-verblist dun-line) -1) (dun-mprinc "I don't understand that.\n")))))) (defun dun-batch-dos-interface () @@ -3142,8 +3145,8 @@ File not found"))) (setq dungeon-mode 'dos) (while (eq dungeon-mode 'dos) (dun-dos-prompt) - (setq line (downcase (dun-read-line))) - (if (eq (dun-parse2 nil dun-dos-verbs line) -1) + (setq dun-line (downcase (dun-read-line))) + (if (eq (dun-parse2 nil dun-dos-verbs dun-line) -1) (progn (sleep-for 1) (dun-mprincl "Bad command or file name")))) @@ -3157,12 +3160,12 @@ File not found"))) (setq dungeon-mode 'unix) (while (eq dungeon-mode 'unix) (dun-mprinc "$ ") - (setq line (downcase (dun-read-line))) - (if (eq (dun-parse2 nil dun-unix-verbs line) -1) + (setq dun-line (downcase (dun-read-line))) + (if (eq (dun-parse2 nil dun-unix-verbs dun-line) -1) (let (esign) - (if (setq esign (string-match "=" line)) - (dun-doassign line esign) - (dun-mprinc (car line-list)) + (if (setq esign (string-match "=" dun-line)) + (dun-doassign dun-line esign) + (dun-mprinc (car dun-line-list)) (dun-mprincl ": not found."))))) (goto-char (point-max)) (dun-mprinc "\n")))) commit 7204577bf90ba8574a0199680626a5ae3f075554 Author: Paul Eggert Date: Thu Feb 23 09:14:06 2017 -0800 Merge from gnulib This incorporates: 2017-02-16 xbinary-io: rename from xsetmode 2017-02-15 xsetmode: new module * lib-src/etags.c (main): * lib-src/hexl.c (main): * src/emacs.c (main) [MSDOS]: Prefer set_binary_mode to the obsolescent SET_BINARY. * lib/binary-io.c, lib/binary-io.h: Copy from gnulib. diff --git a/lib-src/etags.c b/lib-src/etags.c index 1b6ac83c9a..39b90cc6cb 100644 --- a/lib-src/etags.c +++ b/lib-src/etags.c @@ -1255,7 +1255,7 @@ main (int argc, char **argv) if (streq (tagfile, "-")) { tagf = stdout; - SET_BINARY (fileno (stdout)); + set_binary_mode (STDOUT_FILENO, O_BINARY); } else tagf = fopen (tagfile, append_to_tagfile ? "ab" : "wb"); diff --git a/lib-src/hexl.c b/lib-src/hexl.c index 2c7e8c4416..319ce8bc89 100644 --- a/lib-src/hexl.c +++ b/lib-src/hexl.c @@ -76,7 +76,7 @@ main (int argc, char **argv) else if (!strcmp (*argv, "-un") || !strcmp (*argv, "-de")) { un_flag = true; - SET_BINARY (fileno (stdout)); + set_binary_mode (fileno (stdout), O_BINARY); } else if (!strcmp (*argv, "-hex")) /* Hex is the default and is only base supported. */; @@ -109,7 +109,7 @@ main (int argc, char **argv) { fp = stdin; if (!un_flag) - SET_BINARY (fileno (stdin)); + set_binary_mode (fileno (stdin), O_BINARY); } else { diff --git a/lib/binary-io.c b/lib/binary-io.c index d828bcd015..a7558b20fd 100644 --- a/lib/binary-io.c +++ b/lib/binary-io.c @@ -1,4 +1,37 @@ +/* Binary mode I/O. + Copyright 2017 Free Software Foundation, Inc. + + This program is free software: you can redistribute it and/or modify + it under the terms of the GNU General Public License as published by + the Free Software Foundation; either version 3 of the License, or + (at your option) any later version. + + This program is distributed in the hope that it will be useful, + but WITHOUT ANY WARRANTY; without even the implied warranty of + MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the + GNU General Public License for more details. + + You should have received a copy of the GNU General Public License + along with this program. If not, see . */ + #include + #define BINARY_IO_INLINE _GL_EXTERN_INLINE #include "binary-io.h" -typedef int dummy; + +#if defined __DJGPP__ || defined __EMX__ +# include +# include + +int +__gl_setmode_check (int fd) +{ + if (isatty (fd)) + { + errno = EINVAL; + return -1; + } + else + return 0; +} +#endif diff --git a/lib/binary-io.h b/lib/binary-io.h index f766439e2f..9f1dde108e 100644 --- a/lib/binary-io.h +++ b/lib/binary-io.h @@ -33,15 +33,12 @@ _GL_INLINE_HEADER_BEGIN # define BINARY_IO_INLINE _GL_INLINE #endif -/* set_binary_mode (fd, mode) - sets the binary/text I/O mode of file descriptor fd to the given mode - (must be O_BINARY or O_TEXT) and returns the previous mode. */ #if O_BINARY # if defined __EMX__ || defined __DJGPP__ || defined __CYGWIN__ # include /* declares setmode() */ -# define set_binary_mode setmode +# define __gl_setmode setmode # else -# define set_binary_mode _setmode +# define __gl_setmode _setmode # undef fileno # define fileno _fileno # endif @@ -50,7 +47,7 @@ _GL_INLINE_HEADER_BEGIN /* Use a function rather than a macro, to avoid gcc warnings "warning: statement with no effect". */ BINARY_IO_INLINE int -set_binary_mode (int fd, int mode) +__gl_setmode (int fd, int mode) { (void) fd; (void) mode; @@ -58,18 +55,29 @@ set_binary_mode (int fd, int mode) } #endif -/* SET_BINARY (fd); - changes the file descriptor fd to perform binary I/O. */ #if defined __DJGPP__ || defined __EMX__ -# include /* declares isatty() */ - /* Avoid putting stdin/stdout in binary mode if it is connected to - the console, because that would make it impossible for the user - to interrupt the program through Ctrl-C or Ctrl-Break. */ -# define SET_BINARY(fd) ((void) (!isatty (fd) ? (set_binary_mode (fd, O_BINARY), 0) : 0)) +extern int __gl_setmode_check (int); #else -# define SET_BINARY(fd) ((void) set_binary_mode (fd, O_BINARY)) +BINARY_IO_INLINE int +__gl_setmode_check (int fd) { return 0; } #endif +/* Set FD's mode to MODE, which should be either O_TEXT or O_BINARY. + Return the old mode if successful, -1 (setting errno) on failure. + Ordinarily this function would be called 'setmode', since that is + its name on MS-Windows, but it is called 'set_binary_mode' here + to avoid colliding with a BSD function of another name. */ + +BINARY_IO_INLINE int +set_binary_mode (int fd, int mode) +{ + int r = __gl_setmode_check (fd); + return r != 0 ? r : __gl_setmode (fd, mode); +} + +/* This macro is obsolescent. */ +#define SET_BINARY(fd) ((void) set_binary_mode (fd, O_BINARY)) + _GL_INLINE_HEADER_END #endif /* _BINARY_H */ diff --git a/src/emacs.c b/src/emacs.c index e5305e2741..a72f1810d8 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -894,9 +894,9 @@ main (int argc, char **argv) #endif /* not SYSTEM_MALLOC and not HYBRID_MALLOC */ #ifdef MSDOS - SET_BINARY (fileno (stdin)); + set_binary_mode (STDIN_FILENO, O_BINARY); fflush (stdout); - SET_BINARY (fileno (stdout)); + set_binary_mode (STDOUT_FILENO, O_BINARY); #endif /* MSDOS */ /* Skip initial setlocale if LC_ALL is "C", as it's not needed in that case. commit 23e64facf9f74133c6bacedeec56ad782ae69b65 Author: Paul Eggert Date: Thu Feb 23 08:58:39 2017 -0800 hexl: handle large files and I/O errors * lib-src/hexl.c: Include inttypes.h, for PRIxMAX etc. Do not include ctype.h, as the code no longer uses isdigit. (DEFAULT_GROUPING, un_flag, iso_flag, group_by): Now local to ‘main’. (DEFAULT_BASE, endian): Remove; was not really used. (usage): Remove; now done by ‘main’, as that’s simpler. (progname): Now static. (output_error, hexchar): New functions. (main): Use them. Simplify. Remove "-oct", "-big-endian", and "-little-endian" options, as they did not work and were not used. Use SET_BINARY only on stdin, and fopen with "rb" otherwise. Use SET_BINARY only once on stdout. Do not assume file offsets fit in ‘long’. If an I/O error occurs, report it and exit with nonzero status. diff --git a/lib-src/hexl.c b/lib-src/hexl.c index 2eef7b3a63..2c7e8c4416 100644 --- a/lib-src/hexl.c +++ b/lib-src/hexl.c @@ -21,241 +21,201 @@ along with this program. If not, see . */ #include +#include #include #include #include -#include #include -#define DEFAULT_GROUPING 0x01 -#define DEFAULT_BASE 16 +static char *progname; -int base = DEFAULT_BASE; -bool un_flag = false, iso_flag = false, endian = true; -int group_by = DEFAULT_GROUPING; -char *progname; +static _Noreturn void +output_error (void) +{ + fprintf (stderr, "%s: write error\n", progname); + exit (EXIT_FAILURE); +} -_Noreturn void usage (void); +static int +hexchar (int c) +{ + return c - ('0' <= c && c <= '9' ? '0' : 'a' - 10); +} int main (int argc, char **argv) { - register long address; - char string[18]; - FILE *fp; - - progname = *argv++; --argc; + int status = EXIT_SUCCESS; + int DEFAULT_GROUPING = 0x01; + int group_by = DEFAULT_GROUPING; + bool un_flag = false, iso_flag = false; + progname = *argv++; /* ** -hex hex dump - ** -oct Octal dump ** -group-by-8-bits ** -group-by-16-bits ** -group-by-32-bits ** -group-by-64-bits ** -iso iso character set. - ** -big-endian Big Endian - ** -little-endian Little Endian ** -un || -de from hexl format to binary. ** -- End switch list. ** dump filename ** - (as filename == stdin) */ - while (*argv && *argv[0] == '-' && (*argv)[1]) + for (; *argv && *argv[0] == '-' && (*argv)[1]; argv++) { /* A switch! */ if (!strcmp (*argv, "--")) { - --argc; argv++; + argv++; break; } else if (!strcmp (*argv, "-un") || !strcmp (*argv, "-de")) { un_flag = true; - --argc; argv++; + SET_BINARY (fileno (stdout)); } else if (!strcmp (*argv, "-hex")) - { - base = 16; - --argc; argv++; - } + /* Hex is the default and is only base supported. */; else if (!strcmp (*argv, "-iso")) - { - iso_flag = true; - --argc; argv++; - } - else if (!strcmp (*argv, "-oct")) - { - base = 8; - --argc; argv++; - } - else if (!strcmp (*argv, "-big-endian")) - { - endian = true; - --argc; argv++; - } - else if (!strcmp (*argv, "-little-endian")) - { - endian = false; - --argc; argv++; - } + iso_flag = true; else if (!strcmp (*argv, "-group-by-8-bits")) - { - group_by = 0x00; - --argc; argv++; - } + group_by = 0x00; else if (!strcmp (*argv, "-group-by-16-bits")) - { - group_by = 0x01; - --argc; argv++; - } + group_by = 0x01; else if (!strcmp (*argv, "-group-by-32-bits")) - { - group_by = 0x03; - --argc; argv++; - } + group_by = 0x03; else if (!strcmp (*argv, "-group-by-64-bits")) - { - group_by = 0x07; - endian = false; - --argc; argv++; - } + group_by = 0x07; else { fprintf (stderr, "%s: invalid switch: \"%s\".\n", progname, *argv); - usage (); + fprintf (stderr, "usage: %s [-de] [-iso]\n", progname); + return EXIT_FAILURE; } } + char const *filename = *argv ? *argv++ : "-"; + do { - if (*argv == NULL) - fp = stdin; + FILE *fp; + + if (!strcmp (filename, "-")) + { + fp = stdin; + if (!un_flag) + SET_BINARY (fileno (stdin)); + } else { - char *filename = *argv++; - - if (!strcmp (filename, "-")) - fp = stdin; - else if ((fp = fopen (filename, "r")) == NULL) + fp = fopen (filename, un_flag ? "r" : "rb"); + if (!fp) { perror (filename); + status = EXIT_FAILURE; continue; } } if (un_flag) { - SET_BINARY (fileno (stdout)); - - for (;;) + for (int c; 0 <= (c = getc (fp)); ) { - int i, c = 0, d; - char buf[18]; - -#define hexchar(x) (isdigit (x) ? x - '0' : x - 'a' + 10) - - /* Skip 10 bytes. */ - if (fread (buf, 1, 10, fp) != 10) - break; + /* Skip address at start of line. */ + if (c != ' ') + continue; - for (i=0; i < 16; ++i) + for (int i = 0; i < 16; i++) { - if ((c = getc (fp)) == ' ' || c == EOF) + c = getc (fp); + if (c < 0 || c == ' ') break; - d = getc (fp); - c = hexchar (c) * 0x10 + hexchar (d); - putchar (c); - - if ((i&group_by) == group_by) - getc (fp); - } - - if (c == ' ') - { - while ((c = getc (fp)) != '\n' && c != EOF) - ; - - if (c == EOF) - break; - } - else - { - if (i < 16) + int hc = hexchar (c); + c = getc (fp); + if (c < 0) break; + putchar (hc * 0x10 + hexchar (c)); - /* Skip 18 bytes. */ - if (fread (buf, 1, 18, fp) != 18) - break; + if ((i & group_by) == group_by) + { + c = getc (fp); + if (c < 0) + break; + } } + + while (0 <= c && c != '\n') + c = getc (fp); + if (c < 0) + break; + if (ferror (stdout)) + output_error (); } } else { - SET_BINARY (fileno (fp)); - address = 0; + int c = 0; + char string[18]; string[0] = ' '; string[17] = '\0'; - for (;;) + for (uintmax_t address = 0; 0 <= c; address += 0x10) { - register int i, c = 0; - - for (i=0; i < 16; ++i) + int i; + for (i = 0; i < 16; i++) { - if ((c = getc (fp)) == EOF) + if (0 <= c) + c = getc (fp); + if (c < 0) { if (!i) break; fputs (" ", stdout); - string[i+1] = '\0'; + string[i + 1] = '\0'; } else { if (!i) - printf ("%08lx: ", address + 0ul); + printf ("%08"PRIxMAX": ", address); - if (iso_flag) - string[i+1] = - (c < 0x20 || (c >= 0x7F && c < 0xa0)) ? '.' :c; - else - string[i+1] = (c < 0x20 || c >= 0x7F) ? '.' : c; + string[i + 1] + = (c < 0x20 || (0x7F <= c && (!iso_flag || c < 0xa0)) + ? '.' : c); printf ("%02x", c + 0u); } - if ((i&group_by) == group_by) + if ((i & group_by) == group_by) putchar (' '); } if (i) puts (string); - if (c == EOF) - break; - - address += 0x10; - + if (ferror (stdout)) + output_error (); } } - if (fp != stdin) - fclose (fp); + bool trouble = ferror (fp) != 0; + trouble |= fp != stdin && fclose (fp) != 0; + if (trouble) + { + fprintf (stderr, "%s: read error\n", progname); + status = EXIT_FAILURE; + } - } while (*argv != NULL); - return EXIT_SUCCESS; -} + filename = *argv++; + } + while (filename); -void -usage (void) -{ - fprintf (stderr, "usage: %s [-de] [-iso]\n", progname); - exit (EXIT_FAILURE); + if (ferror (stdout) || fclose (stdout) != 0) + output_error (); + return status; } - - -/* hexl.c ends here */ commit 5114b3a2047a9bcdb72fddf35e70201c16eb39a3 Author: Eli Zaretskii Date: Thu Feb 23 18:15:05 2017 +0200 Avoid quitting inside a critical section on MS-Windows * src/w32uniscribe.c (uniscribe_list_family): * src/w32font.c (w32font_list_family, w32font_text_extents) (w32font_list_internal, w32font_match_internal) (list_all_matching_fonts): Prevent quitting while these functions cons lists of fonts, to avoid leaving the critical section taken by the main thread, which will then cause any other thread attempting to enter the critical section to hang. (Bug#25279) diff --git a/src/w32font.c b/src/w32font.c index eff1a78937..37df1bc43c 100644 --- a/src/w32font.c +++ b/src/w32font.c @@ -285,18 +285,25 @@ static Lisp_Object w32font_list_family (struct frame *f) { Lisp_Object list = Qnil; + Lisp_Object prev_quit = Vinhibit_quit; LOGFONT font_match_pattern; HDC dc; memset (&font_match_pattern, 0, sizeof (font_match_pattern)); font_match_pattern.lfCharSet = DEFAULT_CHARSET; + /* Prevent quitting while EnumFontFamiliesEx runs and conses the + list it will return. That's because get_frame_dc acquires the + critical section, so we cannot quit before we release it in + release_frame_dc. */ + Vinhibit_quit = Qt; dc = get_frame_dc (f); EnumFontFamiliesEx (dc, &font_match_pattern, (FONTENUMPROC) add_font_name_to_list, (LPARAM) &list, 0); release_frame_dc (f, dc); + Vinhibit_quit = prev_quit; return list; } @@ -434,6 +441,7 @@ w32font_text_extents (struct font *font, unsigned *code, WORD *wcode; SIZE size; bool first; + Lisp_Object prev_quit = Vinhibit_quit; struct w32font_info *w32_font = (struct w32font_info *) font; @@ -480,6 +488,12 @@ w32font_text_extents (struct font *font, unsigned *code, is updated to pass in a frame. */ f = XFRAME (selected_frame); + /* Prevent quitting while EnumFontFamiliesEx runs and + conses the list it will return. That's because + get_frame_dc acquires the critical section, so we + cannot quit before we release it in release_frame_dc. */ + prev_quit = Vinhibit_quit; + Vinhibit_quit = Qt; dc = get_frame_dc (f); old_font = SelectObject (dc, w32_font->hfont); } @@ -520,6 +534,7 @@ w32font_text_extents (struct font *font, unsigned *code, /* Restore state and release DC. */ SelectObject (dc, old_font); release_frame_dc (f, dc); + Vinhibit_quit = prev_quit; } return; } @@ -556,6 +571,12 @@ w32font_text_extents (struct font *font, unsigned *code, frame. */ f = XFRAME (selected_frame); + /* Prevent quitting while EnumFontFamiliesEx runs and conses the + list it will return. That's because get_frame_dc acquires + the critical section, so we cannot quit before we release it + in release_frame_dc. */ + prev_quit = Vinhibit_quit; + Vinhibit_quit = Qt; dc = get_frame_dc (f); old_font = SelectObject (dc, w32_font->hfont); } @@ -586,6 +607,7 @@ w32font_text_extents (struct font *font, unsigned *code, /* Restore state and release DC. */ SelectObject (dc, old_font); release_frame_dc (f, dc); + Vinhibit_quit = prev_quit; } /* w32 implementation of draw for font backend. @@ -812,12 +834,20 @@ w32font_list_internal (struct frame *f, Lisp_Object font_spec, } else { + Lisp_Object prev_quit = Vinhibit_quit; + + /* Prevent quitting while EnumFontFamiliesEx runs and conses the + list it will return. That's because get_frame_dc acquires + the critical section, so we cannot quit before we release it + in release_frame_dc. */ + Vinhibit_quit = Qt; dc = get_frame_dc (f); EnumFontFamiliesEx (dc, &match_data.pattern, (FONTENUMPROC) add_font_entity_to_list, (LPARAM) &match_data, 0); release_frame_dc (f, dc); + Vinhibit_quit = prev_quit; } return match_data.list; @@ -844,12 +874,19 @@ w32font_match_internal (struct frame *f, Lisp_Object font_spec, if (opentype_only) match_data.pattern.lfOutPrecision = OUT_OUTLINE_PRECIS; + /* Prevent quitting while EnumFontFamiliesEx runs and conses the + list it will return. That's because get_frame_dc acquires the + critical section, so we cannot quit before we release it in + release_frame_dc. */ + Lisp_Object prev_quit = Vinhibit_quit; + Vinhibit_quit = Qt; dc = get_frame_dc (f); EnumFontFamiliesEx (dc, &match_data.pattern, (FONTENUMPROC) add_one_font_entity_to_list, (LPARAM) &match_data, 0); release_frame_dc (f, dc); + Vinhibit_quit = prev_quit; return NILP (match_data.list) ? Qnil : XCAR (match_data.list); } @@ -2064,6 +2101,12 @@ list_all_matching_fonts (struct font_callback_data *match_data) Lisp_Object families = w32font_list_family (XFRAME (match_data->frame)); struct frame *f = XFRAME (match_data->frame); + /* Prevent quitting while EnumFontFamiliesEx runs and conses the + list it will return. That's because get_frame_dc acquires the + critical section, so we cannot quit before we release it in + release_frame_dc. */ + Lisp_Object prev_quit = Vinhibit_quit; + Vinhibit_quit = Qt; dc = get_frame_dc (f); while (!NILP (families)) @@ -2091,6 +2134,7 @@ list_all_matching_fonts (struct font_callback_data *match_data) } release_frame_dc (f, dc); + Vinhibit_quit = prev_quit; } static Lisp_Object diff --git a/src/w32uniscribe.c b/src/w32uniscribe.c index 1584d80f20..e4055638cc 100644 --- a/src/w32uniscribe.c +++ b/src/w32uniscribe.c @@ -89,12 +89,19 @@ uniscribe_list_family (struct frame *f) /* Limit enumerated fonts to outline fonts to save time. */ font_match_pattern.lfOutPrecision = OUT_OUTLINE_PRECIS; + /* Prevent quitting while EnumFontFamiliesEx runs and conses the + list it will return. That's because get_frame_dc acquires the + critical section, so we cannot quit before we release it in + release_frame_dc. */ + Lisp_Object prev_quit = Vinhibit_quit; + Vinhibit_quit = Qt; dc = get_frame_dc (f); EnumFontFamiliesEx (dc, &font_match_pattern, (FONTENUMPROC) add_opentype_font_name_to_list, (LPARAM) &list, 0); release_frame_dc (f, dc); + Vinhibit_quit = prev_quit; return list; }