commit f844c020ca0f70f041a5e617db885bd44bef626e (HEAD, refs/remotes/origin/master) Author: Martin Rudalics Date: Tue Jul 7 08:45:21 2015 +0200 Have `x-show-tip' handle `right' and `bottom' frame parameters. * src/nsfns.m (compute_tip_xy, Fx_show_tip) * src/w32fns.c (compute_tip_xy, Fx_show_tip) * src/xfns.c (compute_tip_xy, Fx_show_tip): Allow aligning tooltips also via `right' and `bottom' frame parameters. diff --git a/etc/NEWS b/etc/NEWS index 3ef5f82..5dc2977 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -1093,8 +1093,8 @@ windows without "fixing" it. It's supported by `fit-window-to-buffer', +++ ** New minor mode `window-divider-mode' and options -`window-divider-default-bottom-width' and -`window-divider-default-right-width'. +`window-divider-default-places', `window-divider-default-bottom-width' +and `window-divider-default-right-width'. +++ ** New option `switch-to-buffer-in-dedicated-window' allows to customize diff --git a/src/nsfns.m b/src/nsfns.m index c6de744..a165304 100644 --- a/src/nsfns.m +++ b/src/nsfns.m @@ -2673,7 +2673,7 @@ compute_tip_xy (struct frame *f, int *root_x, int *root_y) { - Lisp_Object left, top; + Lisp_Object left, top, right, bottom; EmacsView *view = FRAME_NS_VIEW (f); struct ns_display_info *dpyinfo = FRAME_DISPLAY_INFO (f); NSPoint pt; @@ -2681,8 +2681,11 @@ compute_tip_xy (struct frame *f, /* Start with user-specified or mouse position. */ left = Fcdr (Fassq (Qleft, parms)); top = Fcdr (Fassq (Qtop, parms)); + right = Fcdr (Fassq (Qright, parms)); + bottom = Fcdr (Fassq (Qbottom, parms)); - if (!INTEGERP (left) || !INTEGERP (top)) + if ((!INTEGERP (left) && !INTEGERP (right)) + || (!INTEGERP (top) && !INTEGERP (bottom))) { pt.x = dpyinfo->last_mouse_motion_x; pt.y = dpyinfo->last_mouse_motion_y; @@ -2702,13 +2705,14 @@ compute_tip_xy (struct frame *f, else { /* Absolute coordinates. */ - pt.x = XINT (left); - pt.y = x_display_pixel_height (FRAME_DISPLAY_INFO (f)) - XINT (top) - - height; + pt.x = INTEGERP (left) ? XINT (left) : XINT (right); + pt.y = (x_display_pixel_height (FRAME_DISPLAY_INFO (f)) + - (INTEGERP (top) ? XINT (top) : XINT (bottom)) + - height); } /* Ensure in bounds. (Note, screen origin = lower left.) */ - if (INTEGERP (left)) + if (INTEGERP (left) || INTEGERP (right)) *root_x = pt.x; else if (pt.x + XINT (dx) <= 0) *root_x = 0; /* Can happen for negative dx */ @@ -2723,7 +2727,7 @@ compute_tip_xy (struct frame *f, /* Put it left justified on the screen -- it ought to fit that way. */ *root_x = 0; - if (INTEGERP (top)) + if (INTEGERP (top) || INTEGERP (bottom)) *root_y = pt.y; else if (pt.y - XINT (dy) - height >= 0) /* It fits below the pointer. */ @@ -2753,12 +2757,18 @@ Automatically hide the tooltip after TIMEOUT seconds. TIMEOUT nil means use the default timeout of 5 seconds. If the list of frame parameters PARMS contains a `left' parameter, -the tooltip is displayed at that x-position. Otherwise it is -displayed at the mouse position, with offset DX added (default is 5 if -DX isn't specified). Likewise for the y-position; if a `top' frame -parameter is specified, it determines the y-position of the tooltip -window, otherwise it is displayed at the mouse position, with offset -DY added (default is -10). +display the tooltip at that x-position. If the list of frame parameters +PARMS contains no `left' but a `right' parameter, display the tooltip +right-adjusted at that x-position. Otherwise display it at the +x-position of the mouse, with offset DX added (default is 5 if DX isn't +specified). + +Likewise for the y-position: If a `top' frame parameter is specified, it +determines the position of the upper edge of the tooltip window. If a +`bottom' parameter but no `top' frame parameter is specified, it +determines the position of the lower edge of the tooltip window. +Otherwise display the tooltip window at the y-position of the mouse, +with offset DY added (default is -10). A tooltip's maximum size is specified by `x-max-tooltip-size'. Text larger than the specified size is clipped. */) diff --git a/src/w32fns.c b/src/w32fns.c index 6982eca..8f9c56c 100644 --- a/src/w32fns.c +++ b/src/w32fns.c @@ -5941,23 +5941,26 @@ x_create_tip_frame (struct w32_display_info *dpyinfo, parameters for F. DX and DY are specified offsets from the current location of the mouse. WIDTH and HEIGHT are the width and height of the tooltip. Return coordinates relative to the root window of - the display in *ROOT_X, and *ROOT_Y. */ + the display in *ROOT_X and *ROOT_Y. */ static void compute_tip_xy (struct frame *f, Lisp_Object parms, Lisp_Object dx, Lisp_Object dy, int width, int height, int *root_x, int *root_y) { - Lisp_Object left, top; + Lisp_Object left, top, right, bottom; int min_x, min_y, max_x, max_y; /* User-specified position? */ left = Fcdr (Fassq (Qleft, parms)); top = Fcdr (Fassq (Qtop, parms)); + right = Fcdr (Fassq (Qright, parms)); + bottom = Fcdr (Fassq (Qbottom, parms)); /* Move the tooltip window where the mouse pointer is. Resize and show it. */ - if (!INTEGERP (left) || !INTEGERP (top)) + if ((!INTEGERP (left) && !INTEGERP (right)) + || (!INTEGERP (top) && !INTEGERP (bottom))) { POINT pt; @@ -5998,6 +6001,8 @@ compute_tip_xy (struct frame *f, if (INTEGERP (top)) *root_y = XINT (top); + else if (INTEGERP (bottom)) + *root_y = XINT (bottom) - height; else if (*root_y + XINT (dy) <= min_y) *root_y = min_y; /* Can happen for negative dy */ else if (*root_y + XINT (dy) + height <= max_y) @@ -6012,6 +6017,8 @@ compute_tip_xy (struct frame *f, if (INTEGERP (left)) *root_x = XINT (left); + else if (INTEGERP (right)) + *root_y = XINT (right) - width; else if (*root_x + XINT (dx) <= min_x) *root_x = 0; /* Can happen for negative dx */ else if (*root_x + XINT (dx) + width <= max_x) @@ -6041,12 +6048,18 @@ Automatically hide the tooltip after TIMEOUT seconds. TIMEOUT nil means use the default timeout of 5 seconds. If the list of frame parameters PARMS contains a `left' parameter, -the tooltip is displayed at that x-position. Otherwise it is -displayed at the mouse position, with offset DX added (default is 5 if -DX isn't specified). Likewise for the y-position; if a `top' frame -parameter is specified, it determines the y-position of the tooltip -window, otherwise it is displayed at the mouse position, with offset -DY added (default is -10). +display the tooltip at that x-position. If the list of frame parameters +PARMS contains no `left' but a `right' parameter, display the tooltip +right-adjusted at that x-position. Otherwise display it at the +x-position of the mouse, with offset DX added (default is 5 if DX isn't +specified). + +Likewise for the y-position: If a `top' frame parameter is specified, it +determines the position of the upper edge of the tooltip window. If a +`bottom' parameter but no `top' frame parameter is specified, it +determines the position of the lower edge of the tooltip window. +Otherwise display the tooltip window at the y-position of the mouse, +with offset DY added (default is -10). A tooltip's maximum size is specified by `x-max-tooltip-size'. Text larger than the specified size is clipped. */) diff --git a/src/xfns.c b/src/xfns.c index 88d187c..fe3237f 100644 --- a/src/xfns.c +++ b/src/xfns.c @@ -5344,7 +5344,7 @@ x_create_tip_frame (struct x_display_info *dpyinfo, static void compute_tip_xy (struct frame *f, Lisp_Object parms, Lisp_Object dx, Lisp_Object dy, int width, int height, int *root_x, int *root_y) { - Lisp_Object left, top; + Lisp_Object left, top, right, bottom; int win_x, win_y; Window root, child; unsigned pmask; @@ -5352,10 +5352,13 @@ compute_tip_xy (struct frame *f, Lisp_Object parms, Lisp_Object dx, Lisp_Object /* User-specified position? */ left = Fcdr (Fassq (Qleft, parms)); top = Fcdr (Fassq (Qtop, parms)); + right = Fcdr (Fassq (Qright, parms)); + bottom = Fcdr (Fassq (Qbottom, parms)); /* Move the tooltip window where the mouse pointer is. Resize and show it. */ - if (!INTEGERP (left) || !INTEGERP (top)) + if ((!INTEGERP (left) && !INTEGERP (right)) + || (!INTEGERP (top) && !INTEGERP (bottom))) { block_input (); XQueryPointer (FRAME_X_DISPLAY (f), FRAME_DISPLAY_INFO (f)->root_window, @@ -5365,6 +5368,8 @@ compute_tip_xy (struct frame *f, Lisp_Object parms, Lisp_Object dx, Lisp_Object if (INTEGERP (top)) *root_y = XINT (top); + else if (INTEGERP (bottom)) + *root_y = XINT (bottom) - height; else if (*root_y + XINT (dy) <= 0) *root_y = 0; /* Can happen for negative dy */ else if (*root_y + XINT (dy) + height @@ -5380,6 +5385,8 @@ compute_tip_xy (struct frame *f, Lisp_Object parms, Lisp_Object dx, Lisp_Object if (INTEGERP (left)) *root_x = XINT (left); + else if (INTEGERP (right)) + *root_y = XINT (right) - width; else if (*root_x + XINT (dx) <= 0) *root_x = 0; /* Can happen for negative dx */ else if (*root_x + XINT (dx) + width @@ -5409,13 +5416,19 @@ change the tooltip's appearance. Automatically hide the tooltip after TIMEOUT seconds. TIMEOUT nil means use the default timeout of 5 seconds. -If the list of frame parameters PARMS contains a `left' parameters, -the tooltip is displayed at that x-position. Otherwise it is -displayed at the mouse position, with offset DX added (default is 5 if -DX isn't specified). Likewise for the y-position; if a `top' frame -parameter is specified, it determines the y-position of the tooltip -window, otherwise it is displayed at the mouse position, with offset -DY added (default is -10). +If the list of frame parameters PARMS contains a `left' parameter, +display the tooltip at that x-position. If the list of frame parameters +PARMS contains no `left' but a `right' parameter, display the tooltip +right-adjusted at that x-position. Otherwise display it at the +x-position of the mouse, with offset DX added (default is 5 if DX isn't +specified). + +Likewise for the y-position: If a `top' frame parameter is specified, it +determines the position of the upper edge of the tooltip window. If a +`bottom' parameter but no `top' frame parameter is specified, it +determines the position of the lower edge of the tooltip window. +Otherwise display the tooltip window at the y-position of the mouse, +with offset DY added (default is -10). A tooltip's maximum size is specified by `x-max-tooltip-size'. Text larger than the specified size is clipped. */) commit 59b5723c9b613f14cd60cd3239cfdbc0d2343b18 Author: Stefan Monnier Date: Tue Jul 7 02:14:16 2015 -0400 Add online-help support to describe types * lisp/help-fns.el (describe-symbol-backends): Move to help-mode.el. (describe-symbol): Improve the selection of default. * lisp/help-mode.el: Require cl-lib. (describe-symbol-backends): Move from help-fns.el. (help-make-xrefs): Use it. * lisp/emacs-lisp/cl-extra.el (describe-symbol-backends): Add entry for types. (cl--typedef-regexp): New const. (find-function-regexp-alist): Add entry for types. (cl-help-type, cl-type-definition): New buttons. (cl-find-class): New function. (cl-describe-type): New command. (cl--describe-class, cl--describe-class-slot) (cl--describe-class-slots): New functions, moved from eieio-opt.el. * lisp/emacs-lisp/cl-generic.el (cl--generic-method-documentation) (cl--generic-all-functions, cl--generic-specializers-apply-to-type-p): New functions. Moved from eieio-opt.el. (cl--generic-class-parents): New function, extracted from cl--generic-struct-specializers. (cl--generic-struct-specializers): Use it. * lisp/emacs-lisp/cl-macs.el (cl-defstruct): Use pcase-dolist. Improve constructor's docstrings. (cl-struct-unknown-slot): New error. (cl-struct-slot-offset): Use it. * lisp/emacs-lisp/cl-preloaded.el (cl-struct-define): Record the type definition in current-load-list. * lisp/emacs-lisp/eieio-core.el (eieio--known-slot-names): New var. (eieio--add-new-slot): Set it. (eieio-defclass-internal): Use new name for current-load-list. (eieio-oref): Add compiler-macro to warn about unknown slots. * lisp/emacs-lisp/eieio.el (defclass): Update eieio--known-slot-names as compile-time as well. Improve constructor docstrings. * lisp/emacs-lisp/eieio-opt.el (eieio-help-class) (eieio--help-print-slot, eieio-help-class-slots): Move to cl-extra.el. (eieio-class-def): Remove button. (eieio-help-constructor): Use new name for load-history element. (eieio--specializers-apply-to-class-p, eieio-all-generic-functions) (eieio-method-documentation): Move to cl-generic.el. (eieio-display-method-list): Use new names. * lisp/emacs-lisp/lisp-mode.el (lisp-imenu-generic-expression): Add "define-linline". (lisp-fdefs): Remove "defsubst". (el-fdefs): Add "defsubst", "cl-defsubst", and "define-linline". * lisp/emacs-lisp/macroexp.el (macroexp--warned): New var. (macroexp--warn-and-return): Use it to avoid inf-loops. Add `compile-only' argument. diff --git a/lisp/emacs-lisp/cl-extra.el b/lisp/emacs-lisp/cl-extra.el index 3313cc7..38cc772 100644 --- a/lisp/emacs-lisp/cl-extra.el +++ b/lisp/emacs-lisp/cl-extra.el @@ -688,6 +688,169 @@ including `cl-block' and `cl-eval-when'." (prog1 (cl-prettyprint form) (message "")))) +;;; Integration into the online help system. + +(eval-when-compile (require 'cl-macs)) ;Explicitly, for cl--find-class. +(require 'help-mode) + +;; FIXME: We could go crazy and add another entry so describe-symbol can be +;; used with the slot names of CL structs (and/or EIEIO objects). +(add-to-list 'describe-symbol-backends + `(nil ,#'cl-find-class ,(lambda (s _b _f) (cl-describe-type s)))) + +(defconst cl--typedef-regexp + (concat "(" (regexp-opt '("defclass" "defstruct" "cl-defstruct" + "cl-deftype" "deftype")) + "[ \t\r\n]+%s[ \t\r\n]+")) +(with-eval-after-load 'find-func + (defvar find-function-regexp-alist) + (add-to-list 'find-function-regexp-alist + `(define-type . cl--typedef-regexp))) + +(define-button-type 'cl-help-type + :supertype 'help-function-def + 'help-function #'cl-describe-type + 'help-echo (purecopy "mouse-2, RET: describe this type")) + +(define-button-type 'cl-type-definition + :supertype 'help-function-def + 'help-echo (purecopy "mouse-2, RET: find type definition")) + +(declare-function help-fns-short-filename "help-fns" (filename)) + +;;;###autoload +(defun cl-find-class (type) (cl--find-class type)) + +;;;###autoload +(defun cl-describe-type (type) + "Display the documentation for type TYPE (a symbol)." + (interactive + (let ((str (completing-read "Describe type: " obarray #'cl-find-class t))) + (if (<= (length str) 0) + (user-error "Abort!") + (list (intern str))))) + (help-setup-xref (list #'cl-describe-type type) + (called-interactively-p 'interactive)) + (save-excursion + (with-help-window (help-buffer) + (with-current-buffer standard-output + (let ((class (cl-find-class type))) + (if class + (cl--describe-class type class) + ;; FIXME: Describe other types (the built-in ones, or those from + ;; cl-deftype). + (user-error "Unknown type %S" type)))) + (with-current-buffer standard-output + ;; Return the text we displayed. + (buffer-string))))) + +(defun cl--describe-class (type &optional class) + (unless class (setq class (cl--find-class type))) + (let ((location (find-lisp-object-file-name type 'define-type)) + ;; FIXME: Add a `cl-class-of' or `cl-typeof' or somesuch. + (metatype (cl--class-name (symbol-value (aref class 0))))) + (insert (symbol-name type) + (substitute-command-keys " is a type (of kind ‘")) + (help-insert-xref-button (symbol-name metatype) + 'cl-help-type metatype) + (insert (substitute-command-keys "’)")) + (when location + (insert (substitute-command-keys " in ‘")) + (help-insert-xref-button + (help-fns-short-filename location) + 'cl-type-definition type location 'define-type) + (insert (substitute-command-keys "’"))) + (insert ".\n") + + ;; Parents. + (let ((pl (cl--class-parents class)) + cur) + (when pl + (insert " Inherits from ") + (while (setq cur (pop pl)) + (setq cur (cl--class-name cur)) + (insert (substitute-command-keys "‘")) + (help-insert-xref-button (symbol-name cur) + 'cl-help-type cur) + (insert (substitute-command-keys (if pl "’, " "’")))) + (insert ".\n"))) + + ;; Children, if available. ¡For EIEIO! + (let ((ch (condition-case nil + (cl-struct-slot-value metatype 'children class) + (cl-struct-unknown-slot nil))) + cur) + (when ch + (insert " Children ") + (while (setq cur (pop ch)) + (insert (substitute-command-keys "‘")) + (help-insert-xref-button (symbol-name cur) + 'cl-help-type cur) + (insert (substitute-command-keys (if ch "’, " "’")))) + (insert ".\n"))) + + ;; Type's documentation. + (let ((doc (cl--class-docstring class))) + (when doc + (insert "\n" doc "\n\n"))) + + ;; Describe all the slots in this class. + (cl--describe-class-slots class) + + ;; Describe all the methods specific to this class. + (let ((generics (cl--generic-all-functions type))) + (when generics + (insert (propertize "Specialized Methods:\n\n" 'face 'bold)) + (dolist (generic generics) + (insert (substitute-command-keys "‘")) + (help-insert-xref-button (symbol-name generic) + 'help-function generic) + (insert (substitute-command-keys "’")) + (pcase-dolist (`(,qualifiers ,args ,doc) + (cl--generic-method-documentation generic type)) + (insert (format " %s%S\n" qualifiers args) + (or doc ""))) + (insert "\n\n")))))) + +(defun cl--describe-class-slot (slot) + (insert + (concat + (propertize "Slot: " 'face 'bold) + (prin1-to-string (cl--slot-descriptor-name slot)) + (unless (eq (cl--slot-descriptor-type slot) t) + (concat " type = " + (prin1-to-string (cl--slot-descriptor-type slot)))) + ;; FIXME: The default init form is treated differently for structs and for + ;; eieio objects: for structs, the default is nil, for eieio-objects + ;; it's a special "unbound" value. + (unless nil ;; (eq (cl--slot-descriptor-initform slot) eieio-unbound) + (concat " default = " + (prin1-to-string (cl--slot-descriptor-initform slot)))) + (when (alist-get :printer (cl--slot-descriptor-props slot)) + (concat " printer = " + (prin1-to-string + (alist-get :printer (cl--slot-descriptor-props slot))))) + (when (alist-get :documentation (cl--slot-descriptor-props slot)) + (concat "\n " (alist-get :documentation (cl--slot-descriptor-props slot)) + "\n"))) + "\n")) + +(defun cl--describe-class-slots (class) + "Print help description for the slots in CLASS. +Outputs to the current buffer." + (let* ((slots (cl--class-slots class)) + ;; FIXME: Add a `cl-class-of' or `cl-typeof' or somesuch. + (metatype (cl--class-name (symbol-value (aref class 0)))) + ;; ¡For EIEIO! + (cslots (condition-case nil + (cl-struct-slot-value metatype 'class-slots class) + (cl-struct-unknown-slot nil)))) + (insert (propertize "Instance Allocated Slots:\n\n" + 'face 'bold)) + (mapc #'cl--describe-class-slot slots) + (when (> (length cslots) 0) + (insert (propertize "\nClass Allocated Slots:\n\n" 'face 'bold)) + (mapc #'cl--describe-class-slot cslots)))) (run-hooks 'cl-extra-load-hook) diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index 5923e4d..a3bb7c3 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -95,6 +95,7 @@ ;; usually be simplified, or even completely skipped. (eval-when-compile (require 'cl-lib)) +(eval-when-compile (require 'cl-macs)) ;For cl--find-class. (eval-when-compile (require 'pcase)) (cl-defstruct (cl--generic-generalizer @@ -883,6 +884,55 @@ Can only be used from within the lexical body of a primary or around method." (insert (substitute-command-keys "’.\n")))) (insert "\n" (or (nth 2 info) "Undocumented") "\n\n"))))))) +(defun cl--generic-specializers-apply-to-type-p (specializers type) + "Return non-nil if a method with SPECIALIZERS applies to TYPE." + (let ((applies nil)) + (dolist (specializer specializers) + (if (memq (car-safe specializer) '(subclass eieio--static)) + (setq specializer (nth 1 specializer))) + ;; Don't include the methods that are "too generic", such as those + ;; applying to `eieio-default-superclass'. + (and (not (memq specializer '(t eieio-default-superclass))) + (or (equal type specializer) + (when (symbolp specializer) + (let ((sclass (cl--find-class specializer)) + (tclass (cl--find-class type))) + (when (and sclass tclass) + (member specializer (cl--generic-class-parents tclass)))))) + (setq applies t))) + applies)) + +(defun cl--generic-all-functions (&optional type) + "Return a list of all generic functions. +Optional TYPE argument returns only those functions that contain +methods for TYPE." + (let ((l nil)) + (mapatoms + (lambda (symbol) + (let ((generic (and (fboundp symbol) (cl--generic symbol)))) + (and generic + (catch 'found + (if (null type) (throw 'found t)) + (dolist (method (cl--generic-method-table generic)) + (if (cl--generic-specializers-apply-to-type-p + (cl--generic-method-specializers method) type) + (throw 'found t)))) + (push symbol l))))) + l)) + +(defun cl--generic-method-documentation (function type) + "Return info for all methods of FUNCTION (a symbol) applicable to TYPE. +The value returned is a list of elements of the form +\(QUALIFIERS ARGS DOC)." + (let ((generic (cl--generic function)) + (docs ())) + (when generic + (dolist (method (cl--generic-method-table generic)) + (when (cl--generic-specializers-apply-to-type-p + (cl--generic-method-specializers method) type) + (push (cl--generic-method-info method) docs)))) + docs)) + ;;; Support for (head ) specializers. ;; For both the `eql' and the `head' specializers, the dispatch @@ -958,19 +1008,22 @@ Can only be used from within the lexical body of a primary or around method." (if (eq (symbol-function tag) :quick-object-witness-check) tag)))) +(defun cl--generic-class-parents (class) + (let ((parents ()) + (classes (list class))) + ;; BFS precedence. FIXME: Use a topological sort. + (while (let ((class (pop classes))) + (cl-pushnew (cl--class-name class) parents) + (setq classes + (append classes + (cl--class-parents class))))) + (nreverse parents))) + (defun cl--generic-struct-specializers (tag) (and (symbolp tag) (boundp tag) (let ((class (symbol-value tag))) (when (cl-typep class 'cl-structure-class) - (let ((types ()) - (classes (list class))) - ;; BFS precedence. - (while (let ((class (pop classes))) - (push (cl--class-name class) types) - (setq classes - (append classes - (cl--class-parents class))))) - (nreverse types)))))) + (cl--generic-class-parents class))))) (defconst cl--generic-struct-generalizer (cl-generic-make-generalizer diff --git a/lisp/emacs-lisp/cl-macs.el b/lisp/emacs-lisp/cl-macs.el index 5bcf088..f5e1ffb 100644 --- a/lisp/emacs-lisp/cl-macs.el +++ b/lisp/emacs-lisp/cl-macs.el @@ -2722,20 +2722,16 @@ non-nil value, that slot cannot be set via `setf'. (push `(defalias ',copier #'copy-sequence) forms)) (if constructor (push (list constructor - (cons '&key (delq nil (copy-sequence slots)))) - constrs)) - (while constrs - (let* ((name (caar constrs)) - (rest (cdr (pop constrs))) - (args (car rest)) - (doc (cadr rest)) - (anames (cl--arglist-args args)) + (cons '&key (delq nil (copy-sequence slots)))) + constrs)) + (pcase-dolist (`(,cname ,args ,doc) constrs) + (let* ((anames (cl--arglist-args args)) (make (cl-mapcar (function (lambda (s d) (if (memq s anames) s d))) slots defaults))) - (push `(cl-defsubst ,name + (push `(cl-defsubst ,cname (&cl-defs (nil ,@descs) ,@args) - ,@(if (stringp doc) (list doc) - (if (stringp docstring) (list docstring))) + ,(if (stringp doc) (list doc) + (format "Constructor for objects of type `%s'." name)) ,@(if (cl--safe-expr-p `(progn ,@(mapcar #'cl-second descs))) '((declare (side-effect-free t)))) (,(or type #'vector) ,@make)) @@ -2859,6 +2855,8 @@ slots skipped by :initial-offset may appear in the list." descs))) (nreverse descs))) +(define-error 'cl-struct-unknown-slot "struct %S has no slot %S") + (defun cl-struct-slot-offset (struct-type slot-name) "Return the offset of slot SLOT-NAME in STRUCT-TYPE. The returned zero-based slot index is relative to the start of @@ -2868,7 +2866,7 @@ does not contain SLOT-NAME." (declare (side-effect-free t) (pure t)) (or (gethash slot-name (cl--class-index-table (cl--struct-get-class struct-type))) - (error "struct %s has no slot %s" struct-type slot-name))) + (signal 'cl-struct-unknown-slot (list struct-type slot-name)))) (defvar byte-compile-function-environment) (defvar byte-compile-macro-environment) diff --git a/lisp/emacs-lisp/cl-preloaded.el b/lisp/emacs-lisp/cl-preloaded.el index 60f6542..03480b2 100644 --- a/lisp/emacs-lisp/cl-preloaded.el +++ b/lisp/emacs-lisp/cl-preloaded.el @@ -147,6 +147,7 @@ ok) (error "Included struct %S has changed since compilation of %S" parent name)))) + (add-to-list 'current-load-list `(define-type . ,name)) (cl--struct-register-child parent-class tag) (unless (eq named t) (eval `(defconst ,tag ',class) t) diff --git a/lisp/emacs-lisp/eieio-core.el b/lisp/emacs-lisp/eieio-core.el index 8a09f07..7fcf85c 100644 --- a/lisp/emacs-lisp/eieio-core.el +++ b/lisp/emacs-lisp/eieio-core.el @@ -261,6 +261,8 @@ It creates an autoload function for CNAME's constructor." (and (eieio-object-p obj) (object-of-class-p obj class)))) +(defvar eieio--known-slot-names nil) + (defun eieio-defclass-internal (cname superclasses slots options) "Define CNAME as a new subclass of SUPERCLASSES. SLOTS are the slots residing in that class definition, and OPTIONS @@ -473,7 +475,7 @@ See `defclass' for more information." (put cname 'variable-documentation docstring))) ;; Save the file location where this class is defined. - (add-to-list 'current-load-list `(eieio-defclass . ,cname)) + (add-to-list 'current-load-list `(define-type . ,cname)) ;; We have a list of custom groups. Store them into the options. (let ((g (eieio--class-option-assoc options :custom-groups))) @@ -603,47 +605,48 @@ if default value is nil." :key #'cl--slot-descriptor-name))) (cold (car (cl-member a (eieio--class-class-slots newc) :key #'cl--slot-descriptor-name)))) - (condition-case nil - (if (sequencep d) (setq d (copy-sequence d))) - ;; This copy can fail on a cons cell with a non-cons in the cdr. Let's - ;; skip it if it doesn't work. - (error nil)) - ;; (if (sequencep type) (setq type (copy-sequence type))) - ;; (if (sequencep cust) (setq cust (copy-sequence cust))) - ;; (if (sequencep custg) (setq custg (copy-sequence custg))) - - ;; To prevent override information w/out specification of storage, - ;; we need to do this little hack. - (if cold (setq alloc :class)) - - (if (memq alloc '(nil :instance)) - ;; In this case, we modify the INSTANCE version of a given slot. - (progn - ;; Only add this element if it is so-far unique - (if (not old) - (progn - (eieio--perform-slot-validation-for-default slot skipnil) - (push slot (eieio--class-slots newc)) - ) - ;; When defaultoverride is true, we are usually adding new local - ;; attributes which must override the default value of any slot - ;; passed in by one of the parent classes. - (when defaultoverride - (eieio--slot-override old slot skipnil))) - (when init - (cl-pushnew (cons init a) (eieio--class-initarg-tuples newc) - :test #'equal))) - - ;; CLASS ALLOCATED SLOTS - (if (not cold) + (cl-pushnew a eieio--known-slot-names) + (condition-case nil + (if (sequencep d) (setq d (copy-sequence d))) + ;; This copy can fail on a cons cell with a non-cons in the cdr. Let's + ;; skip it if it doesn't work. + (error nil)) + ;; (if (sequencep type) (setq type (copy-sequence type))) + ;; (if (sequencep cust) (setq cust (copy-sequence cust))) + ;; (if (sequencep custg) (setq custg (copy-sequence custg))) + + ;; To prevent override information w/out specification of storage, + ;; we need to do this little hack. + (if cold (setq alloc :class)) + + (if (memq alloc '(nil :instance)) + ;; In this case, we modify the INSTANCE version of a given slot. (progn - (eieio--perform-slot-validation-for-default slot skipnil) - ;; Here we have found a :class version of a slot. This - ;; requires a very different approach. - (push slot (eieio--class-class-slots newc))) - (when defaultoverride - ;; There is a match, and we must override the old value. - (eieio--slot-override cold slot skipnil)))))) + ;; Only add this element if it is so-far unique + (if (not old) + (progn + (eieio--perform-slot-validation-for-default slot skipnil) + (push slot (eieio--class-slots newc)) + ) + ;; When defaultoverride is true, we are usually adding new local + ;; attributes which must override the default value of any slot + ;; passed in by one of the parent classes. + (when defaultoverride + (eieio--slot-override old slot skipnil))) + (when init + (cl-pushnew (cons init a) (eieio--class-initarg-tuples newc) + :test #'equal))) + + ;; CLASS ALLOCATED SLOTS + (if (not cold) + (progn + (eieio--perform-slot-validation-for-default slot skipnil) + ;; Here we have found a :class version of a slot. This + ;; requires a very different approach. + (push slot (eieio--class-class-slots newc))) + (when defaultoverride + ;; There is a match, and we must override the old value. + (eieio--slot-override cold slot skipnil)))))) (defun eieio-copy-parents-into-subclass (newc) "Copy into NEWC the slots of PARENTS. @@ -720,9 +723,18 @@ Argument FN is the function calling this verifier." ;;; Get/Set slots in an object. -;; + (defun eieio-oref (obj slot) "Return the value in OBJ at SLOT in the object vector." + (declare (compiler-macro + (lambda (exp) + (ignore obj) + (pcase slot + ((and (or `',name (and name (pred keywordp))) + (guard (not (memq name eieio--known-slot-names)))) + (macroexp--warn-and-return + (format "Unknown slot `%S'" name) exp 'compile-only)) + (_ exp))))) (cl-check-type slot symbol) (cl-check-type obj (or eieio-object class)) (let* ((class (cond ((symbolp obj) diff --git a/lisp/emacs-lisp/eieio-opt.el b/lisp/emacs-lisp/eieio-opt.el index f7dbdf5..9ecc594 100644 --- a/lisp/emacs-lisp/eieio-opt.el +++ b/lisp/emacs-lisp/eieio-opt.el @@ -31,7 +31,6 @@ (require 'eieio) (require 'find-func) (require 'speedbar) -(require 'help-mode) ;;; Code: ;;;###autoload @@ -78,101 +77,7 @@ Argument CH-PREFIX is another character prefix to display." (declare-function help-fns-short-filename "help-fns" (filename)) ;;;###autoload -(defun eieio-help-class (class) - "Print help description for CLASS. -If CLASS is actually an object, then also display current values of that object." - ;; Header line - (prin1 class) - (insert " is a" - (if (eieio--class-option (cl--find-class class) :abstract) - "n abstract" - "") - " class") - (let ((location (find-lisp-object-file-name class 'eieio-defclass))) - (when location - (insert (substitute-command-keys " in ‘")) - (help-insert-xref-button - (help-fns-short-filename location) - 'eieio-class-def class location 'eieio-defclass) - (insert (substitute-command-keys "’")))) - (insert ".\n") - ;; Parents - (let ((pl (eieio-class-parents class)) - cur) - (when pl - (insert " Inherits from ") - (while (setq cur (pop pl)) - (setq cur (eieio--class-name cur)) - (insert (substitute-command-keys "‘")) - (help-insert-xref-button (symbol-name cur) - 'help-function cur) - (insert (substitute-command-keys (if pl "’, " "’")))) - (insert ".\n"))) - ;; Children - (let ((ch (eieio-class-children class)) - cur) - (when ch - (insert " Children ") - (while (setq cur (pop ch)) - (insert (substitute-command-keys "‘")) - (help-insert-xref-button (symbol-name cur) - 'help-function cur) - (insert (substitute-command-keys (if ch "’, " "’")))) - (insert ".\n"))) - ;; System documentation - (let ((doc (documentation-property class 'variable-documentation))) - (when doc - (insert "\n" doc "\n\n"))) - ;; Describe all the slots in this class. - (eieio-help-class-slots class) - ;; Describe all the methods specific to this class. - (let ((generics (eieio-all-generic-functions class))) - (when generics - (insert (propertize "Specialized Methods:\n\n" 'face 'bold)) - (dolist (generic generics) - (insert (substitute-command-keys "‘")) - (help-insert-xref-button (symbol-name generic) 'help-function generic) - (insert (substitute-command-keys "’")) - (pcase-dolist (`(,qualifiers ,args ,doc) - (eieio-method-documentation generic class)) - (insert (format " %s%S\n" qualifiers args) - (or doc ""))) - (insert "\n\n"))))) - -(defun eieio--help-print-slot (slot) - (insert - (concat - (propertize "Slot: " 'face 'bold) - (prin1-to-string (cl--slot-descriptor-name slot)) - (unless (eq (cl--slot-descriptor-type slot) t) - (concat " type = " - (prin1-to-string (cl--slot-descriptor-type slot)))) - (unless (eq (cl--slot-descriptor-initform slot) eieio-unbound) - (concat " default = " - (prin1-to-string (cl--slot-descriptor-initform slot)))) - (when (alist-get :printer (cl--slot-descriptor-props slot)) - (concat " printer = " - (prin1-to-string - (alist-get :printer (cl--slot-descriptor-props slot))))) - (when (alist-get :documentation (cl--slot-descriptor-props slot)) - (concat "\n " (alist-get :documentation (cl--slot-descriptor-props slot)) - "\n"))) - "\n")) - -(defun eieio-help-class-slots (class) - "Print help description for the slots in CLASS. -Outputs to the current buffer." - (let* ((cv (cl--find-class class)) - (slots (eieio--class-slots cv)) - (cslots (eieio--class-class-slots cv))) - (insert (propertize "Instance Allocated Slots:\n\n" - 'face 'bold)) - (dotimes (i (length slots)) - (eieio--help-print-slot (aref slots i))) - (when (> (length cslots) 0) - (insert (propertize "\nClass Allocated Slots:\n\n" 'face 'bold))) - (dotimes (i (length cslots)) - (eieio--help-print-slot (aref cslots i))))) +(define-obsolete-function-alias 'eieio-help-class 'cl--describe-class "25.1") (defun eieio-build-class-alist (&optional class instantiable-only buildlist) "Return an alist of all currently active classes for completion purposes. @@ -217,22 +122,13 @@ are not abstract." ;;; METHOD COMPLETION / DOC -(define-button-type 'eieio-class-def - :supertype 'help-function-def - 'help-echo (purecopy "mouse-2, RET: find class definition")) - -(defconst eieio--defclass-regexp "(defclass[ \t\r\n]+%s[ \t\r\n]+") -(with-eval-after-load 'find-func - (defvar find-function-regexp-alist) - (add-to-list 'find-function-regexp-alist - `(eieio-defclass . eieio--defclass-regexp))) ;;;###autoload (defun eieio-help-constructor (ctr) "Describe CTR if it is a class constructor." (when (class-p ctr) (erase-buffer) - (let ((location (find-lisp-object-file-name ctr 'eieio-defclass)) + (let ((location (find-lisp-object-file-name ctr 'define-type)) (def (symbol-function ctr))) (goto-char (point-min)) (prin1 ctr) @@ -248,7 +144,7 @@ are not abstract." (insert (substitute-command-keys " in ‘")) (help-insert-xref-button (help-fns-short-filename location) - 'eieio-class-def ctr location 'eieio-defclass) + 'cl-type-definition ctr location 'define-type) (insert (substitute-command-keys "’"))) (insert ".\nCreates an object of class " (symbol-name ctr) ".") (goto-char (point-max)) @@ -259,50 +155,6 @@ are not abstract." (eieio-help-class ctr)) )))) -(defun eieio--specializers-apply-to-class-p (specializers class) - "Return non-nil if a method with SPECIALIZERS applies to CLASS." - (let ((applies nil)) - (dolist (specializer specializers) - (if (memq (car-safe specializer) '(subclass eieio--static)) - (setq specializer (nth 1 specializer))) - ;; Don't include the methods that are "too generic", such as those - ;; applying to `eieio-default-superclass'. - (and (not (memq specializer '(t eieio-default-superclass))) - (class-p specializer) - (child-of-class-p class specializer) - (setq applies t))) - applies)) - -(defun eieio-all-generic-functions (&optional class) - "Return a list of all generic functions. -Optional CLASS argument returns only those functions that contain -methods for CLASS." - (let ((l nil)) - (mapatoms - (lambda (symbol) - (let ((generic (and (fboundp symbol) (cl--generic symbol)))) - (and generic - (catch 'found - (if (null class) (throw 'found t)) - (dolist (method (cl--generic-method-table generic)) - (if (eieio--specializers-apply-to-class-p - (cl--generic-method-specializers method) class) - (throw 'found t)))) - (push symbol l))))) - l)) - -(defun eieio-method-documentation (generic class) - "Return info for all methods of GENERIC applicable to CLASS. -The value returned is a list of elements of the form -\(QUALIFIERS ARGS DOC)." - (let ((generic (cl--generic generic)) - (docs ())) - (when generic - (dolist (method (cl--generic-method-table generic)) - (when (eieio--specializers-apply-to-class-p - (cl--generic-method-specializers method) class) - (push (cl--generic-method-info method) docs)))) - docs)) ;;; METHOD STATS ;; @@ -310,7 +162,7 @@ The value returned is a list of elements of the form (defun eieio-display-method-list () "Display a list of all the methods and what features are used." (interactive) - (let* ((meth1 (eieio-all-generic-functions)) + (let* ((meth1 (cl--generic-all-functions)) (meth (sort meth1 (lambda (a b) (string< (symbol-name a) (symbol-name b))))) diff --git a/lisp/emacs-lisp/eieio.el b/lisp/emacs-lisp/eieio.el index eee848f..84a68a8 100644 --- a/lisp/emacs-lisp/eieio.el +++ b/lisp/emacs-lisp/eieio.el @@ -142,6 +142,10 @@ and reference them using the function `class-option'." (alloc (plist-get soptions :allocation)) (label (plist-get soptions :label))) + ;; Update eieio--known-slot-names already in case we compile code which + ;; uses this before the class is loaded. + (cl-pushnew sname eieio--known-slot-names) + (if eieio-error-unsupported-class-tags (let ((tmp soptions)) (while tmp @@ -254,13 +258,12 @@ This method is obsolete." (if (not (stringp abs)) (setq abs (format "Class %s is abstract" name))) `(defun ,name (&rest _) - ,(format "You cannot create a new object of type %S." name) + ,(format "You cannot create a new object of type `%S'." name) (error ,abs))) ;; Non-abstract classes need a constructor. `(defun ,name (&rest slots) - ,(format "Create a new object with name NAME of class type %S." - name) + ,(format "Create a new object of class type `%S'." name) (declare (compiler-macro (lambda (whole) (if (not (stringp (car slots))) @@ -941,6 +944,8 @@ of `eq'." (error "EIEIO: `change-class' is unimplemented")) ;; Hook ourselves into help system for describing classes and methods. +;; FIXME: This is not actually needed any more since we can click on the +;; hyperlink from the constructor's docstring to see the type definition. (add-hook 'help-fns-describe-function-functions 'eieio-help-constructor) ;;; Interfacing with edebug @@ -978,7 +983,7 @@ Optional argument GROUP is the sub-group of slots to display. ;;;*** -;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "b7995d9076e4dd4b9358b2aa66835619") +;;;### (autoloads nil "eieio-opt" "eieio-opt.el" "cb1aba7670b6a4b9c6f968c0ad6dc130") ;;; Generated autoloads from eieio-opt.el (autoload 'eieio-browse "eieio-opt" "\ @@ -988,11 +993,7 @@ variable `eieio-default-superclass'. \(fn &optional ROOT-CLASS)" t nil) -(autoload 'eieio-help-class "eieio-opt" "\ -Print help description for CLASS. -If CLASS is actually an object, then also display current values of that object. - -\(fn CLASS)" nil nil) +(define-obsolete-function-alias 'eieio-help-class 'cl--describe-class "25.1") (autoload 'eieio-help-constructor "eieio-opt" "\ Describe CTR if it is a class constructor. diff --git a/lisp/emacs-lisp/lisp-mode.el b/lisp/emacs-lisp/lisp-mode.el index 72a23cf..8aa34c7 100644 --- a/lisp/emacs-lisp/lisp-mode.el +++ b/lisp/emacs-lisp/lisp-mode.el @@ -95,7 +95,7 @@ (regexp-opt '("defun" "defmacro" ;; Elisp. - "defun*" "defsubst" + "defun*" "defsubst" "define-inline" "define-advice" "defadvice" "define-skeleton" "define-compilation-mode" "define-minor-mode" "define-global-minor-mode" @@ -230,7 +230,7 @@ (throw 'found t)))))) (let-when-compile - ((lisp-fdefs '("defmacro" "defsubst" "defun")) + ((lisp-fdefs '("defmacro" "defun")) (lisp-vdefs '("defvar")) (lisp-kw '("cond" "if" "while" "let" "let*" "progn" "prog1" "prog2" "lambda" "unwind-protect" "condition-case" @@ -240,7 +240,8 @@ ;; Elisp constructs. Now they are update dynamically ;; from obarray but they are also used for setting up ;; the keywords for Common Lisp. - (el-fdefs '("define-advice" "defadvice" "defalias" + (el-fdefs '("defsubst" "cl-defsubst" "define-inline" + "define-advice" "defadvice" "defalias" "define-derived-mode" "define-minor-mode" "define-generic-mode" "define-global-minor-mode" "define-globalized-minor-mode" "define-skeleton" diff --git a/lisp/emacs-lisp/macroexp.el b/lisp/emacs-lisp/macroexp.el index 57cbec5..ffc6585 100644 --- a/lisp/emacs-lisp/macroexp.el +++ b/lisp/emacs-lisp/macroexp.el @@ -119,20 +119,28 @@ and also to avoid outputting the warning during normal execution." (member '(declare-function . byte-compile-macroexpand-declare-function) macroexpand-all-environment)) +(defvar macroexp--warned (make-hash-table :test #'equal :weakness 'key)) -(defun macroexp--warn-and-return (msg form) +(defun macroexp--warn-and-return (msg form &optional compile-only) (let ((when-compiled (lambda () (byte-compile-log-warning msg t)))) (cond ((null msg) form) ((macroexp--compiling-p) - `(progn - (macroexp--funcall-if-compiled ',when-compiled) - ,form)) + (if (gethash form macroexp--warned) + ;; Already wrapped this exp with a warning: avoid inf-looping + ;; where we keep adding the same warning onto `form' because + ;; macroexpand-all gets right back to macroexpanding `form'. + form + (puthash form form macroexp--warned) + `(progn + (macroexp--funcall-if-compiled ',when-compiled) + ,form))) (t - (message "%s%s" (if (stringp load-file-name) - (concat (file-relative-name load-file-name) ": ") - "") - msg) + (unless compile-only + (message "%s%s" (if (stringp load-file-name) + (concat (file-relative-name load-file-name) ": ") + "") + msg)) form)))) (defun macroexp--obsolete-warning (fun obsolescence-data type) @@ -208,30 +216,30 @@ Assumes the caller has bound `macroexpand-all-environment'." (macroexp--cons 'condition-case (macroexp--cons err - (macroexp--cons (macroexp--expand-all body) - (macroexp--all-clauses handlers 1) - (cddr form)) - (cdr form)) + (macroexp--cons (macroexp--expand-all body) + (macroexp--all-clauses handlers 1) + (cddr form)) + (cdr form)) form)) (`(,(or `defvar `defconst) . ,_) (macroexp--all-forms form 2)) (`(function ,(and f `(lambda . ,_))) (macroexp--cons 'function - (macroexp--cons (macroexp--all-forms f 2) - nil - (cdr form)) - form)) + (macroexp--cons (macroexp--all-forms f 2) + nil + (cdr form)) + form)) (`(,(or `function `quote) . ,_) form) (`(,(and fun (or `let `let*)) . ,(or `(,bindings . ,body) dontcare)) (macroexp--cons fun - (macroexp--cons (macroexp--all-clauses bindings 1) - (macroexp--all-forms body) - (cdr form)) - form)) + (macroexp--cons (macroexp--all-clauses bindings 1) + (macroexp--all-forms body) + (cdr form)) + form)) (`(,(and fun `(lambda . ,_)) . ,args) ;; Embedded lambda in function position. (macroexp--cons (macroexp--all-forms fun 2) - (macroexp--all-forms args) - form)) + (macroexp--all-forms args) + form)) ;; The following few cases are for normal function calls that ;; are known to funcall one of their arguments. The byte ;; compiler has traditionally handled these functions specially diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 0a22c5e..1c7a68a 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -33,6 +33,7 @@ ;;; Code: (require 'cl-lib) +(require 'help-mode) (defvar help-fns-describe-function-functions nil "List of functions to run in help buffer in `describe-function'. @@ -970,15 +971,6 @@ file-local variable.\n") (buffer-string)))))))) -(defvar describe-symbol-backends - `((nil ,#'fboundp ,(lambda (s _b _f) (describe-function s))) - ("face" ,#'facep ,(lambda (s _b _f) (describe-face s))) - (nil - ,(lambda (symbol) - (or (and (boundp symbol) (not (keywordp symbol))) - (get symbol 'variable-documentation))) - ,#'describe-variable))) - (defvar help-xref-stack-item) ;;;###autoload @@ -986,23 +978,22 @@ file-local variable.\n") "Display the full documentation of SYMBOL. Will show the info of SYMBOL as a function, variable, and/or face." (interactive - ;; FIXME: also let the user enter a face name. - (let* ((v-or-f (variable-at-point)) - (found (symbolp v-or-f)) + (let* ((v-or-f (symbol-at-point)) + (found (cl-some (lambda (x) (funcall (nth 1 x) v-or-f)) + describe-symbol-backends)) (v-or-f (if found v-or-f (function-called-at-point))) (found (or found v-or-f)) (enable-recursive-minibuffers t) - val) - (setq val (completing-read (if found + (val (completing-read (if found (format - "Describe symbol (default %s): " v-or-f) + "Describe symbol (default %s): " v-or-f) "Describe symbol: ") obarray (lambda (vv) (cl-some (lambda (x) (funcall (nth 1 x) vv)) describe-symbol-backends)) t nil nil - (if found (symbol-name v-or-f)))) + (if found (symbol-name v-or-f))))) (list (if (equal val "") v-or-f (intern val))))) (if (not (symbolp symbol)) diff --git a/lisp/help-mode.el b/lisp/help-mode.el index cdddd54..e1fc9fd 100644 --- a/lisp/help-mode.el +++ b/lisp/help-mode.el @@ -30,6 +30,7 @@ ;;; Code: (require 'button) +(require 'cl-lib) (eval-when-compile (require 'easymenu)) (defvar help-mode-map @@ -216,7 +217,8 @@ The format is (FUNCTION ARGS...).") (goto-char (point-min)) (if (re-search-forward (format "^[ \t]*(\\(cl-\\)?define-compiler-macro[ \t]+%s" - (regexp-quote (symbol-name fun))) nil t) + (regexp-quote (symbol-name fun))) + nil t) (forward-line 0) (message "Unable to find location in file"))) (message "Unable to find file"))) @@ -385,6 +387,15 @@ it does not already exist." (error "Current buffer is not in Help mode")) (current-buffer)))) +(defvar describe-symbol-backends + `((nil ,#'fboundp ,(lambda (s _b _f) (describe-function s))) + ("face" ,#'facep ,(lambda (s _b _f) (describe-face s))) + (nil + ,(lambda (symbol) + (or (and (boundp symbol) (not (keywordp symbol))) + (get symbol 'variable-documentation))) + ,#'describe-variable))) + ;;;###autoload (defun help-make-xrefs (&optional buffer) "Parse and hyperlink documentation cross-references in the given BUFFER. @@ -487,28 +498,9 @@ that." ;; (pop-to-buffer (car location)) ;; (goto-char (cdr location)))) (help-xref-button 8 'help-function-def sym)) - ((and - (facep sym) - (save-match-data (looking-at "[ \t\n]+face\\W"))) - (help-xref-button 8 'help-face sym)) - ((and (or (boundp sym) - (get sym 'variable-documentation)) - (fboundp sym)) - ;; We can't intuit whether to use the - ;; variable or function doc -- supply both. - (help-xref-button 8 'help-symbol sym)) - ((and - (or (boundp sym) - (get sym 'variable-documentation)) - (or - (documentation-property - sym 'variable-documentation) - (documentation-property - (indirect-variable sym) - 'variable-documentation))) - (help-xref-button 8 'help-variable sym)) - ((fboundp sym) - (help-xref-button 8 'help-function sym))))))) + ((cl-some (lambda (x) (funcall (nth 1 x) sym)) + describe-symbol-backends) + (help-xref-button 8 'help-symbol sym))))))) ;; An obvious case of a key substitution: (save-excursion (while (re-search-forward commit 287bce988895b104c33d53faacfffd91d8d8e0f1 Author: Fabián Ezequiel Gallina Date: Mon Jul 6 20:08:01 2015 -0300 python.el: Fix local/remote shell environment setup * lisp/progmodes/python.el (python-shell-with-environment): Fix remote/local environment setup. * test/automated/python-tests.el (python-shell-with-environment-1) (python-shell-with-environment-2): New tests. diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el index 1c0f105..95814fa 100644 --- a/lisp/progmodes/python.el +++ b/lisp/progmodes/python.el @@ -2060,23 +2060,24 @@ execution of body. If `default-directory' points to a remote machine then modifies `tramp-remote-process-environment' and `tramp-remote-path' instead." (declare (indent 0) (debug (body))) - (let ((remote-p (file-remote-p default-directory))) - `(let ((process-environment - (if ,remote-p - process-environment - (python-shell-calculate-process-environment))) - (tramp-remote-process-environment - (if ,remote-p - (python-shell-calculate-process-environment) - tramp-remote-process-environment)) - (exec-path - (if ,remote-p - (python-shell-calculate-exec-path) - exec-path)) - (tramp-remote-path - (if ,remote-p - (python-shell-calculate-exec-path) - tramp-remote-path))) + (let ((remote-p (make-symbol "remote-p"))) + `(let* ((,remote-p (file-remote-p default-directory)) + (process-environment + (if ,remote-p + process-environment + (python-shell-calculate-process-environment))) + (tramp-remote-process-environment + (if ,remote-p + (python-shell-calculate-process-environment) + tramp-remote-process-environment)) + (exec-path + (if ,remote-p + exec-path + (python-shell-calculate-exec-path))) + (tramp-remote-path + (if ,remote-p + (python-shell-calculate-exec-path) + tramp-remote-path))) ,(macroexp-progn body)))) (defvar python-shell--prompt-calculated-input-regexp nil diff --git a/test/automated/python-tests.el b/test/automated/python-tests.el index 2ed0746..d490f7f 100644 --- a/test/automated/python-tests.el +++ b/test/automated/python-tests.el @@ -27,6 +27,7 @@ ;; Dependencies for testing: (require 'electric) (require 'hideshow) +(require 'tramp-sh) (defmacro python-tests-with-temp-buffer (contents &rest body) @@ -2463,17 +2464,12 @@ Using `python-shell-interpreter' and (ert-deftest python-shell-calculate-process-environment-3 () "Test `python-shell-virtualenv-root' modification." - (let* ((original-path (or (getenv "PATH") "")) - (python-shell-virtualenv-root + (let* ((python-shell-virtualenv-root (directory-file-name user-emacs-directory)) (process-environment (python-shell-calculate-process-environment))) (should (not (getenv "PYTHONHOME"))) - (should (string= (getenv "VIRTUAL_ENV") python-shell-virtualenv-root)) - (should (equal (getenv "PATH") - (format "%s/bin%s%s" - python-shell-virtualenv-root - path-separator original-path))))) + (should (string= (getenv "VIRTUAL_ENV") python-shell-virtualenv-root)))) (ert-deftest python-shell-calculate-process-environment-4 () "Test `python-shell-unbuffered' modification." @@ -2503,7 +2499,7 @@ Using `python-shell-interpreter' and original-exec-path))))) (ert-deftest python-shell-calculate-exec-path-2 () - "Test `python-shell-exec-path' modification." + "Test `python-shell-virtualenv-root' modification." (let* ((original-exec-path exec-path) (python-shell-virtualenv-root (directory-file-name (expand-file-name user-emacs-directory))) @@ -2514,6 +2510,38 @@ Using `python-shell-interpreter' and (format "%s/bin" python-shell-virtualenv-root) original-exec-path)))))) +(ert-deftest python-shell-with-environment-1 () + "Test with local `default-directory'." + (let* ((original-exec-path exec-path) + (python-shell-virtualenv-root + (directory-file-name (expand-file-name user-emacs-directory)))) + (python-shell-with-environment + (should (equal + exec-path + (append (cons + (format "%s/bin" python-shell-virtualenv-root) + original-exec-path)))) + (should (not (getenv "PYTHONHOME"))) + (should (string= (getenv "VIRTUAL_ENV") python-shell-virtualenv-root))))) + +(ert-deftest python-shell-with-environment-2 () + "Test with remote `default-directory'." + (let* ((default-directory "/ssh::/example/dir/") + (original-exec-path tramp-remote-path) + (original-process-environment tramp-remote-process-environment) + (python-shell-virtualenv-root + (directory-file-name (expand-file-name user-emacs-directory)))) + (python-shell-with-environment + (should (equal + tramp-remote-path + (append (cons + (format "%s/bin" python-shell-virtualenv-root) + original-exec-path)))) + (let ((process-environment tramp-remote-process-environment)) + (should (not (getenv "PYTHONHOME"))) + (should (string= (getenv "VIRTUAL_ENV") + python-shell-virtualenv-root)))))) + (ert-deftest python-shell-make-comint-1 () "Check comint creation for global shell buffer." (skip-unless (executable-find python-tests-shell-interpreter)) commit 60ea900848ee03e1ccdba565220f589e0d8e72e9 Author: Glenn Morris Date: Mon Jul 6 16:35:45 2015 -0400 * lisp/simple.el (set-variable): Tweak recent doc fix. diff --git a/lisp/simple.el b/lisp/simple.el index 24ce6c3..7eed279 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -7315,8 +7315,9 @@ If VARIABLE has been defined with `defcustom', then the type information in the definition is used to check that VALUE is valid. Note that this function is at heart equivalent to the basic `set' function. -For a VARIABLE defined with `defcustom', it is not the same as using -\\[customize-variable]. +For a variable defined with `defcustom', it does not pay attention to +any :set property that the variable might have (if you want that, use +\\[customize-set-variable] instead). With a prefix argument, set VARIABLE to VALUE buffer-locally." (interactive commit f3480939ffccf7a72b060b4fc21dd85b55f535f6 Author: Ken Brown Date: Mon Jul 6 16:00:37 2015 -0400 * src/sysdep.c (handle_sigsegv) [CYGWIN]: Increase STACK_DANGER_ZONE diff --git a/src/sysdep.c b/src/sysdep.c index 0a0b0ac..91036f0 100644 --- a/src/sysdep.c +++ b/src/sysdep.c @@ -1646,7 +1646,14 @@ handle_sigsegv (int sig, siginfo_t *siginfo, void *arg) if (!getrlimit (RLIMIT_STACK, &rlim)) { + /* STACK_DANGER_ZONE has to be bigger than 16K on Cygwin, for + reasons explained in + https://www.cygwin.com/ml/cygwin/2015-06/msg00381.html. */ +#ifdef CYGWIN + enum { STACK_DANGER_ZONE = 32 * 1024 }; +#else enum { STACK_DANGER_ZONE = 16 * 1024 }; +#endif char *beg, *end, *addr; beg = stack_bottom; commit 6d1df4ee879411f7ec1b10cbfd5a35267c3a1d78 Author: Glenn Morris Date: Mon Jul 6 15:30:51 2015 -0400 * lisp/simple.el (set-variable): Use user-error for type mismatch. diff --git a/lisp/simple.el b/lisp/simple.el index 5ee32d5..24ce6c3 100644 --- a/lisp/simple.el +++ b/lisp/simple.el @@ -7362,8 +7362,8 @@ With a prefix argument, set VARIABLE to VALUE buffer-locally." (require 'cus-edit) (setq type (widget-convert type)) (unless (widget-apply type :match value) - (error "Value `%S' does not match type %S of %S" - value (car type) variable)))) + (user-error "Value `%S' does not match type %S of %S" + value (car type) variable)))) (if make-local (make-local-variable variable)) commit b81507813a404a9984fd3e8db4dcc1d814d1667b Author: Ken Brown Date: Mon Jul 6 15:08:47 2015 -0400 * src/emacs.c (main): Don't increase the stack size on Cygwin diff --git a/src/emacs.c b/src/emacs.c index 8396f5d..aad9306 100644 --- a/src/emacs.c +++ b/src/emacs.c @@ -846,10 +846,13 @@ main (int argc, char **argv) } #endif /* HAVE_PERSONALITY_LINUX32 */ -#if defined (HAVE_SETRLIMIT) && defined (RLIMIT_STACK) - /* Extend the stack space available. - Don't do that if dumping, since some systems (e.g. DJGPP) - might define a smaller stack limit at that time. */ +#if defined (HAVE_SETRLIMIT) && defined (RLIMIT_STACK) && !defined (CYGWIN) + /* Extend the stack space available. Don't do that if dumping, + since some systems (e.g. DJGPP) might define a smaller stack + limit at that time. And it's not needed on Cygwin, since emacs + is built with an 8MB stack. Moreover, the setrlimit call can + cause problems on Cygwin + (https://www.cygwin.com/ml/cygwin/2015-07/msg00096.html). */ if (1 #ifndef CANNOT_DUMP && (!noninteractive || initialized) @@ -883,7 +886,7 @@ main (int argc, char **argv) setrlimit (RLIMIT_STACK, &rlim); } -#endif /* HAVE_SETRLIMIT and RLIMIT_STACK */ +#endif /* HAVE_SETRLIMIT and RLIMIT_STACK and not CYGWIN */ /* Record (approximately) where the stack begins. */ stack_bottom = &stack_bottom_variable; commit 824fc04b660631e7ff976a36b7f70f7c3d5fc181 Author: Stefan Monnier Date: Mon Jul 6 13:25:26 2015 -0400 (describe-symbol): Rewrite describe-function-or-variable * lisp/help-fns.el (describe-symbol-backends): New var. (help-xref-stack-item): Declare. (describe-symbol): Rename from describe-function-or-variable. Rewrite using describe-symbol-backends instead of help-xref-interned. * lisp/help.el (help-map): Use it. * lisp/help-mode.el (help-symbol, help-follow-symbol): Use it. (help-xref-interned): Make it into an obsolete alias. diff --git a/etc/NEWS b/etc/NEWS index 7717fd0..3ef5f82 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -84,6 +84,8 @@ command line when `initial-buffer-choice' is non-nil. * Changes in Emacs 25.1 +** New doc command `describe-symbol'. Works for functions, vars, faces, etc... + ** `isearch' and `query-replace' now perform character folding in matches. This is analogous to case-folding, but applies between Unicode characters and their ASCII counterparts. This means many characters diff --git a/lisp/help-fns.el b/lisp/help-fns.el index 9541d47..0a22c5e 100644 --- a/lisp/help-fns.el +++ b/lisp/help-fns.el @@ -32,6 +32,8 @@ ;;; Code: +(require 'cl-lib) + (defvar help-fns-describe-function-functions nil "List of functions to run in help buffer in `describe-function'. Those functions will be run after the header line and argument @@ -968,13 +970,23 @@ file-local variable.\n") (buffer-string)))))))) +(defvar describe-symbol-backends + `((nil ,#'fboundp ,(lambda (s _b _f) (describe-function s))) + ("face" ,#'facep ,(lambda (s _b _f) (describe-face s))) + (nil + ,(lambda (symbol) + (or (and (boundp symbol) (not (keywordp symbol))) + (get symbol 'variable-documentation))) + ,#'describe-variable))) + +(defvar help-xref-stack-item) + ;;;###autoload -(defun describe-function-or-variable (symbol &optional buffer frame) - "Display the full documentation of the function or variable SYMBOL. -If SYMBOL is a variable and has a buffer-local value in BUFFER or FRAME -\(default to the current buffer and current frame), it is displayed along -with the global value." +(defun describe-symbol (symbol &optional buffer frame) + "Display the full documentation of SYMBOL. +Will show the info of SYMBOL as a function, variable, and/or face." (interactive + ;; FIXME: also let the user enter a face name. (let* ((v-or-f (variable-at-point)) (found (symbolp v-or-f)) (v-or-f (if found v-or-f (function-called-at-point))) @@ -983,21 +995,54 @@ with the global value." val) (setq val (completing-read (if found (format - "Describe function or variable (default %s): " v-or-f) - "Describe function or variable: ") + "Describe symbol (default %s): " v-or-f) + "Describe symbol: ") obarray (lambda (vv) - (or (fboundp vv) - (get vv 'variable-documentation) - (and (boundp vv) (not (keywordp vv))))) + (cl-some (lambda (x) (funcall (nth 1 x) vv)) + describe-symbol-backends)) t nil nil (if found (symbol-name v-or-f)))) (list (if (equal val "") v-or-f (intern val))))) - (if (not (symbolp symbol)) (message "You didn't specify a function or variable") - (unless (buffer-live-p buffer) (setq buffer (current-buffer))) - (unless (frame-live-p frame) (setq frame (selected-frame))) - (help-xref-interned symbol buffer frame))) + (if (not (symbolp symbol)) + (user-error "You didn't specify a function or variable")) + (unless (buffer-live-p buffer) (setq buffer (current-buffer))) + (unless (frame-live-p frame) (setq frame (selected-frame))) + (with-current-buffer (help-buffer) + ;; Push the previous item on the stack before clobbering the output buffer. + (help-setup-xref nil nil) + (let* ((docs + (nreverse + (delq nil + (mapcar (pcase-lambda (`(,name ,testfn ,descfn)) + (when (funcall testfn symbol) + ;; Don't record the current entry in the stack. + (setq help-xref-stack-item nil) + (cons name + (funcall descfn symbol buffer frame)))) + describe-symbol-backends)))) + (single (null (cdr docs)))) + (while (cdr docs) + (goto-char (point-min)) + (let ((inhibit-read-only t) + (name (caar docs)) ;Name of doc currently at BOB. + (doc (cdr (cadr docs)))) ;Doc to add at BOB. + (insert doc) + (delete-region (point) (progn (skip-chars-backward " \t\n") (point))) + (insert "\n\n" + (eval-when-compile + (propertize "\n" 'face '(:height 0.1 :inverse-video t))) + "\n") + (when name + (insert (symbol-name symbol) + " is also a " name "." "\n\n"))) + (setq docs (cdr docs))) + (unless single + ;; Don't record the `describe-variable' item in the stack. + (setq help-xref-stack-item nil) + (help-setup-xref (list #'describe-symbol symbol) nil)) + (goto-char (point-min))))) ;;;###autoload (defun describe-syntax (&optional buffer) diff --git a/lisp/help-mode.el b/lisp/help-mode.el index 6454eed..cdddd54 100644 --- a/lisp/help-mode.el +++ b/lisp/help-mode.el @@ -148,7 +148,7 @@ The format is (FUNCTION ARGS...).") (define-button-type 'help-symbol :supertype 'help-xref - 'help-function #'help-xref-interned + 'help-function #'describe-symbol 'help-echo (purecopy "mouse-2, RET: describe this symbol")) (define-button-type 'help-back @@ -624,58 +624,7 @@ See `help-make-xrefs'." ;; Additional functions for (re-)creating types of help buffers. ;;;###autoload -(defun help-xref-interned (symbol &optional buffer frame) - "Follow a hyperlink which appeared to be an arbitrary interned SYMBOL. -Both variable, function and face documentation are extracted into a single -help buffer. If SYMBOL is a variable, include buffer-local value for optional -BUFFER or FRAME." - (with-current-buffer (help-buffer) - ;; Push the previous item on the stack before clobbering the output buffer. - (help-setup-xref nil nil) - (let ((facedoc (when (facep symbol) - ;; Don't record the current entry in the stack. - (setq help-xref-stack-item nil) - (describe-face symbol))) - (fdoc (when (fboundp symbol) - ;; Don't record the current entry in the stack. - (setq help-xref-stack-item nil) - (describe-function symbol))) - (sdoc (when (or (boundp symbol) - (get symbol 'variable-documentation)) - ;; Don't record the current entry in the stack. - (setq help-xref-stack-item nil) - (describe-variable symbol buffer frame)))) - (cond - (sdoc - ;; We now have a help buffer on the variable. - ;; Insert the function and face text before it. - (when (or fdoc facedoc) - (goto-char (point-min)) - (let ((inhibit-read-only t)) - (when fdoc - (insert fdoc "\n\n") - (when facedoc - (insert (make-string 30 ?-) "\n\n" (symbol-name symbol) - " is also a " "face." "\n\n"))) - (when facedoc - (insert facedoc "\n\n")) - (insert (make-string 30 ?-) "\n\n" (symbol-name symbol) - " is also a " "variable." "\n\n")) - ;; Don't record the `describe-variable' item in the stack. - (setq help-xref-stack-item nil) - (help-setup-xref (list #'help-xref-interned symbol) nil))) - (fdoc - ;; We now have a help buffer on the function. - ;; Insert face text before it. - (when facedoc - (goto-char (point-max)) - (let ((inhibit-read-only t)) - (insert "\n\n" (make-string 30 ?-) "\n\n" (symbol-name symbol) - " is also a " "face." "\n\n" facedoc)) - ;; Don't record the `describe-function' item in the stack. - (setq help-xref-stack-item nil) - (help-setup-xref (list #'help-xref-interned symbol) nil)))) - (goto-char (point-min))))) +(define-obsolete-function-alias 'help-xref-interned 'describe-symbol "25.1") ;; Navigation/hyperlinking with xrefs @@ -774,7 +723,7 @@ Show all docs for that symbol as either a variable, function or face." (when (or (boundp sym) (get sym 'variable-documentation) (fboundp sym) (facep sym)) - (help-do-xref pos #'help-xref-interned (list sym))))) + (help-do-xref pos #'describe-symbol (list sym))))) (defun help-mode-revert-buffer (_ignore-auto noconfirm) (when (or noconfirm (yes-or-no-p "Revert help buffer? ")) diff --git a/lisp/help.el b/lisp/help.el index 7a3460c..1826cb7 100644 --- a/lisp/help.el +++ b/lisp/help.el @@ -95,7 +95,7 @@ (define-key map "k" 'describe-key) (define-key map "l" 'view-lossage) (define-key map "m" 'describe-mode) - (define-key map "o" 'describe-function-or-variable) + (define-key map "o" 'describe-symbol) (define-key map "n" 'view-emacs-news) (define-key map "p" 'finder-by-keyword) (define-key map "P" 'describe-package) commit 2a8dca13a7f5efd36390e5a93e55d3809f325c21 Author: Stefan Monnier Date: Mon Jul 6 11:55:37 2015 -0400 (eieio-persistent-save): Don't ignore `file' arg (bug#20972) * lisp/emacs-lisp/eieio-base.el (eieio-persistent-save): Don't ignore `file' arg. Always use utf-8-emacs. Use with-temp-buffer and cl-letf. diff --git a/lisp/emacs-lisp/eieio-base.el b/lisp/emacs-lisp/eieio-base.el index 2e28036..400bdb9 100644 --- a/lisp/emacs-lisp/eieio-base.el +++ b/lisp/emacs-lisp/eieio-base.el @@ -429,37 +429,28 @@ Optional argument COMMENT is a header line comment." "Save persistent object THIS to disk. Optional argument FILE overrides the file name specified in the object instance." - (save-excursion - (let ((b (set-buffer (get-buffer-create " *tmp object write*"))) - (default-directory (file-name-directory (oref this file))) - (cfn (oref this file))) - (unwind-protect - (save-excursion - (erase-buffer) - (let ((standard-output (current-buffer))) - (oset this file - (if file - (eieio-persistent-path-relative this file) - (file-name-nondirectory cfn))) - (object-write this (oref this file-header-line))) - (let ((backup-inhibited (not (oref this do-backups))) - (cs (car (find-coding-systems-region - (point-min) (point-max))))) - (unless (eq cs 'undecided) - (setq buffer-file-coding-system cs)) - ;; Old way - write file. Leaves message behind. - ;;(write-file cfn nil) - - ;; New way - Avoid the vast quantities of error checking - ;; just so I can get at the special flags that disable - ;; displaying random messages. - (write-region (point-min) (point-max) - cfn nil 1) - )) - ;; Restore :file, and kill the tmp buffer - (oset this file cfn) - (setq buffer-file-name nil) - (kill-buffer b))))) + (when file (setq file (expand-file-name file))) + (with-temp-buffer + (let* ((cfn (or file (oref this file))) + (default-directory (file-name-directory cfn))) + (cl-letf ((standard-output (current-buffer)) + ((oref this file) ;FIXME: Why change it? + (if file + ;; FIXME: Makes a name relative to (oref this file), + ;; whereas I think it should be relative to cfn. + (eieio-persistent-path-relative this file) + (file-name-nondirectory cfn)))) + (object-write this (oref this file-header-line))) + (let ((backup-inhibited (not (oref this do-backups))) + (coding-system-for-write 'utf-8-emacs)) + ;; Old way - write file. Leaves message behind. + ;;(write-file cfn nil) + + ;; New way - Avoid the vast quantities of error checking + ;; just so I can get at the special flags that disable + ;; displaying random messages. + (write-region (point-min) (point-max) cfn nil 1) + )))) ;; Notes on the persistent object: ;; It should also set up some hooks to help it keep itself up to date. commit c96dd0223c82855485f4666e30161bc151716c7f Author: Wolfgang Jenkner Date: Mon Jul 6 15:10:27 2015 +0200 ; Auto-commit of loaddefs files. diff --git a/lisp/dired.el b/lisp/dired.el index 02946e0..5593083 100644 --- a/lisp/dired.el +++ b/lisp/dired.el @@ -4398,7 +4398,7 @@ instead. ;;;*** -;;;### (autoloads nil "dired-x" "dired-x.el" "d8d702a50887671b9128ba60bd9ebb8e") +;;;### (autoloads nil "dired-x" "dired-x.el" "183a6677a0dfc9e853e24b05abda5490") ;;; Generated autoloads from dired-x.el (autoload 'dired-jump "dired-x" "\ commit c020517dc14fa850135fb362eeffbc45aee1fb49 Author: Wolfgang Jenkner Date: Mon Jul 6 15:10:03 2015 +0200 Fix parsing glitches in dired-mark-sexp (bug#13575) * lisp/dired-x.el (dired-x--string-to-number): New function. (dired-mark-sexp): Use it. Tweak dired-re-inode-size. Fix usage of directory-listing-before-filename-regexp. Consider forward-word harmful and replace it. Add more verbiage in comments and doc string. diff --git a/lisp/dired-x.el b/lisp/dired-x.el index eebfa91..c90306a 100644 --- a/lisp/dired-x.el +++ b/lisp/dired-x.el @@ -1396,6 +1396,22 @@ Considers buffers closer to the car of `buffer-list' to be more recent." ;; result)) +;; Needed if ls -lh is supported and also for GNU ls -ls. +(defun dired-x--string-to-number (str) + "Like `string-to-number' but recognize a trailing unit prefix. +For example, 2K is expanded to 2048.0. The caller should make +sure that a trailing letter in STR is one of BKkMGTPEZY." + (let* ((val (string-to-number str)) + (u (unless (zerop val) + (aref str (1- (length str)))))) + (when (and u (> u ?9)) + (when (= u ?k) + (setq u ?K)) + (let ((units '(?B ?K ?M ?G ?T ?P ?E ?Z ?Y))) + (while (and units (/= (pop units) u)) + (setq val (* 1024.0 val))))) + val)) + ;; Does anyone use this? - lrd 6/29/93. ;; Apparently people do use it. - lrd 12/22/97. @@ -1422,7 +1438,19 @@ For example, use (equal 0 size) -to mark all zero length files." +to mark all zero length files. + +There's an ambiguity when a single integer not followed by a unit +prefix precedes the file mode: It is then parsed as inode number +and not as block size (this always works for GNU coreutils ls). + +Another limitation is that the uid field is needed for the +function to work correctly. In particular, the field is not +present for some values of `ls-lisp-emulation'. + +This function operates only on the buffer content and does not +refer at all to the underlying file system. Contrast this with +`find-dired', which might be preferable for the task at hand." ;; Using sym="" instead of nil avoids the trap of ;; (string-match "foo" sym) into which a user would soon fall. ;; Give `equal' instead of `=' in the example, as this works on @@ -1442,23 +1470,23 @@ to mark all zero length files." ;; to nil or the appropriate value, so they need not be initialized. ;; Moves point within the current line. (dired-move-to-filename) - (let (pos - (mode-len 10) ; length of mode string - ;; like in dired.el, but with subexpressions \1=inode, \2=s: - (dired-re-inode-size "\\s *\\([0-9]*\\)\\s *\\([0-9]*\\) ?")) - (beginning-of-line) - (forward-char 2) - (if (looking-at dired-re-inode-size) - (progn - (goto-char (match-end 0)) - (setq inode (string-to-number - (buffer-substring (match-beginning 1) - (match-end 1))) - s (string-to-number - (buffer-substring (match-beginning 2) - (match-end 2))))) - (setq inode nil - s nil)) + (let ((mode-len 10) ; length of mode string + ;; like in dired.el, but with subexpressions \1=inode, \2=s: + ;; GNU ls -hs suffixes the block count with a unit and + ;; prints it as a float, FreeBSD does neither. + (dired-re-inode-size "\\=\\s *\\([0-9]+\\s +\\)?\ +\\(?:\\([0-9]+\\(?:\\.[0-9]*\\)?[BkKMGTPEZY]?\\)? ?\\)")) + (beginning-of-line) + (forward-char 2) + (search-forward-regexp dired-re-inode-size nil t) + ;; XXX Might be a size not followed by a unit prefix. + ;; We could set s to inode if it were otherwise nil, + ;; with a similar reasoning as below for setting gid to uid, + ;; but it would be even more whimsical. + (setq inode (when (match-string 1) + (string-to-number (match-string 1)))) + (setq s (when (match-string 2) + (dired-x--string-to-number (match-string 2)))) (setq mode (buffer-substring (point) (+ mode-len (point)))) (forward-char mode-len) ;; Skip any extended attributes marker ("." or "+"). @@ -1466,33 +1494,60 @@ to mark all zero length files." (forward-char 1)) (setq nlink (read (current-buffer))) ;; Karsten Wenger fixed uid. - (setq uid (buffer-substring (1+ (point)) - (progn (forward-word 1) (point)))) - (re-search-forward directory-listing-before-filename-regexp) - (goto-char (match-beginning 1)) - (forward-char -1) - (setq size (string-to-number - (buffer-substring (save-excursion - (backward-word 1) - (setq pos (point))) + ;; Another issue is that GNU ls -n right-justifies numerical + ;; UIDs and GIDs, while FreeBSD left-justifies them, so + ;; don't rely on a specific whitespace layout. Both of them + ;; right-justify all other numbers, though. + ;; XXX Return a number if the uid or gid seems to be + ;; numerical? + (setq uid (buffer-substring (progn + (skip-chars-forward " \t") + (point)) + (progn + (skip-chars-forward "^ \t") (point)))) - (goto-char pos) - (backward-word 1) - ;; if no gid is displayed, gid will be set to uid - ;; but user will then not reference it anyway in PREDICATE. - (setq gid (buffer-substring (save-excursion - (forward-word 1) (point)) + (dired-move-to-filename) + (save-excursion + (setq time + ;; The regexp below tries to match from the last + ;; digit of the size field through a space after the + ;; date. Also, dates may have different formats + ;; depending on file age, so the date column need + ;; not be aligned to the right. + (buffer-substring (save-excursion + (skip-chars-backward " \t") (point)) - time (buffer-substring (match-beginning 1) - (1- (dired-move-to-filename))) - name (buffer-substring (point) - (or - (dired-move-to-end-of-filename t) - (point))) - sym (if (looking-at-p " -> ") - (buffer-substring (progn (forward-char 4) (point)) - (line-end-position)) - "")) + (progn + (re-search-backward + directory-listing-before-filename-regexp) + (skip-chars-forward "^ \t") + (1+ (point)))) + size (dired-x--string-to-number + ;; We know that there's some kind of number + ;; before point because the regexp search + ;; above succeeded. I don't think it's worth + ;; doing an extra check for leading garbage. + (buffer-substring (point) + (progn + (skip-chars-backward "^ \t") + (point)))) + ;; If no gid is displayed, gid will be set to uid + ;; but the user will then not reference it anyway in + ;; PREDICATE. + gid (buffer-substring (progn + (skip-chars-backward " \t") + (point)) + (progn + (skip-chars-backward "^ \t") + (point))))) + (setq name (buffer-substring (point) + (or + (dired-move-to-end-of-filename t) + (point))) + sym (if (looking-at " -> ") + (buffer-substring (progn (forward-char 4) (point)) + (line-end-position)) + "")) t) (eval predicate `((inode . ,inode) commit 0fdc3f2ee839646cf41691f04a33252f05b7060e Author: Fabián Ezequiel Gallina Date: Mon Jul 6 07:57:14 2015 -0300 python.el: Respect process environment for remote shells * lisp/progmodes/python.el (python-shell-calculate-process-environment): Calculate process-environment or tramp-remote-process-environment depending whether current file is remote. (python-shell-calculate-exec-path): Calculate exec-path or tramp-remote-path depending whether current file is remote. (python-shell-with-environment): New macro. (python-shell-prompt-detect, python-shell-calculate-command) (python-shell-make-comint, python-check): Use it. diff --git a/lisp/progmodes/python.el b/lisp/progmodes/python.el index 339f240..1c0f105 100644 --- a/lisp/progmodes/python.el +++ b/lisp/progmodes/python.el @@ -180,6 +180,12 @@ ;; shell so that relative imports work properly using the ;; `python-shell-package-enable' command. +;; Shell remote support: remote Python shells are started with the +;; correct environment for files opened remotely through tramp, also +;; respecting dir-local variables provided `enable-remote-dir-locals' +;; is non-nil. The logic for this is transparently handled by the +;; `python-shell-with-environment' macro. + ;; Shell syntax highlighting: when enabled current input in shell is ;; highlighted. The variable `python-shell-font-lock-enable' controls ;; activation of this feature globally when shells are started. @@ -255,6 +261,7 @@ (require 'cl-lib) (require 'comint) (require 'json) +(require 'tramp-sh) ;; Avoid compiler warnings (defvar view-return-to-alist) @@ -2001,6 +2008,77 @@ virtualenv." :type '(alist string) :group 'python) +(defun python-shell-calculate-process-environment () + "Calculate `process-environment' or `tramp-remote-process-environment'. +Pre-appends `python-shell-process-environment', sets extra +pythonpaths from `python-shell-extra-pythonpaths' and sets a few +virtualenv related vars. If `default-directory' points to a +remote machine, the returned value is intended for +`tramp-remote-process-environment'." + (let* ((remote-p (file-remote-p default-directory)) + (process-environment (append + python-shell-process-environment + (if remote-p + tramp-remote-process-environment + process-environment) nil)) + (virtualenv (if python-shell-virtualenv-root + (directory-file-name python-shell-virtualenv-root) + nil))) + (when python-shell-unbuffered + (setenv "PYTHONUNBUFFERED" "1")) + (when python-shell-extra-pythonpaths + (setenv "PYTHONPATH" (python-shell-calculate-pythonpath))) + (if (not virtualenv) + process-environment + (setenv "PYTHONHOME" nil) + (setenv "VIRTUAL_ENV" virtualenv)) + process-environment)) + +(defun python-shell-calculate-exec-path () + "Calculate `exec-path' or `tramp-remote-path'. +Pre-appends `python-shell-exec-path' and adds the binary +directory for virtualenv if `python-shell-virtualenv-root' is +set. If `default-directory' points to a remote machine, the +returned value is intended for `tramp-remote-path'." + (let ((path (append + ;; Use nil as the tail so that the list is a full copy, + ;; this is a paranoid safeguard for side-effects. + python-shell-exec-path + (if (file-remote-p default-directory) + tramp-remote-path + exec-path) + nil))) + (if (not python-shell-virtualenv-root) + path + (cons (expand-file-name "bin" python-shell-virtualenv-root) + path)))) + +(defmacro python-shell-with-environment (&rest body) + "Modify shell environment during execution of BODY. +Temporarily sets `process-environment' and `exec-path' during +execution of body. If `default-directory' points to a remote +machine then modifies `tramp-remote-process-environment' and +`tramp-remote-path' instead." + (declare (indent 0) (debug (body))) + (let ((remote-p (file-remote-p default-directory))) + `(let ((process-environment + (if ,remote-p + process-environment + (python-shell-calculate-process-environment))) + (tramp-remote-process-environment + (if ,remote-p + (python-shell-calculate-process-environment) + tramp-remote-process-environment)) + (exec-path + (if ,remote-p + (python-shell-calculate-exec-path) + exec-path)) + (tramp-remote-path + (if ,remote-p + (python-shell-calculate-exec-path) + tramp-remote-path))) + ,(macroexp-progn body)))) + (defvar python-shell--prompt-calculated-input-regexp nil "Calculated input prompt regexp for inferior python shell. Do not set this variable directly, instead use @@ -2023,69 +2101,68 @@ shows a warning with instructions to avoid hangs and returns nil. When `python-shell-prompt-detect-enabled' is nil avoids any detection and just returns nil." (when python-shell-prompt-detect-enabled - (let* ((process-environment (python-shell-calculate-process-environment)) - (exec-path (python-shell-calculate-exec-path)) - (code (concat - "import sys\n" - "ps = [getattr(sys, 'ps%s' % i, '') for i in range(1,4)]\n" - ;; JSON is built manually for compatibility - "ps_json = '\\n[\"%s\", \"%s\", \"%s\"]\\n' % tuple(ps)\n" - "print (ps_json)\n" - "sys.exit(0)\n")) - (output - (with-temp-buffer - ;; TODO: improve error handling by using - ;; `condition-case' and displaying the error message to - ;; the user in the no-prompts warning. - (ignore-errors - (let ((code-file (python-shell--save-temp-file code))) - ;; Use `process-file' as it is remote-host friendly. - (process-file - python-shell-interpreter - code-file - '(t nil) - nil - python-shell-interpreter-interactive-arg) - ;; Try to cleanup - (delete-file code-file))) - (buffer-string))) - (prompts - (catch 'prompts - (dolist (line (split-string output "\n" t)) - (let ((res - ;; Check if current line is a valid JSON array - (and (string= (substring line 0 2) "[\"") - (ignore-errors - ;; Return prompts as a list, not vector - (append (json-read-from-string line) nil))))) - ;; The list must contain 3 strings, where the first - ;; is the input prompt, the second is the block - ;; prompt and the last one is the output prompt. The - ;; input prompt is the only one that can't be empty. - (when (and (= (length res) 3) - (cl-every #'stringp res) - (not (string= (car res) ""))) - (throw 'prompts res)))) - nil))) - (when (and (not prompts) - python-shell-prompt-detect-failure-warning) - (lwarn - '(python python-shell-prompt-regexp) - :warning - (concat - "Python shell prompts cannot be detected.\n" - "If your emacs session hangs when starting python shells\n" - "recover with `keyboard-quit' and then try fixing the\n" - "interactive flag for your interpreter by adjusting the\n" - "`python-shell-interpreter-interactive-arg' or add regexps\n" - "matching shell prompts in the directory-local friendly vars:\n" - " + `python-shell-prompt-regexp'\n" - " + `python-shell-prompt-block-regexp'\n" - " + `python-shell-prompt-output-regexp'\n" - "Or alternatively in:\n" - " + `python-shell-prompt-input-regexps'\n" - " + `python-shell-prompt-output-regexps'"))) - prompts))) + (python-shell-with-environment + (let* ((code (concat + "import sys\n" + "ps = [getattr(sys, 'ps%s' % i, '') for i in range(1,4)]\n" + ;; JSON is built manually for compatibility + "ps_json = '\\n[\"%s\", \"%s\", \"%s\"]\\n' % tuple(ps)\n" + "print (ps_json)\n" + "sys.exit(0)\n")) + (output + (with-temp-buffer + ;; TODO: improve error handling by using + ;; `condition-case' and displaying the error message to + ;; the user in the no-prompts warning. + (ignore-errors + (let ((code-file (python-shell--save-temp-file code))) + ;; Use `process-file' as it is remote-host friendly. + (process-file + python-shell-interpreter + code-file + '(t nil) + nil + python-shell-interpreter-interactive-arg) + ;; Try to cleanup + (delete-file code-file))) + (buffer-string))) + (prompts + (catch 'prompts + (dolist (line (split-string output "\n" t)) + (let ((res + ;; Check if current line is a valid JSON array + (and (string= (substring line 0 2) "[\"") + (ignore-errors + ;; Return prompts as a list, not vector + (append (json-read-from-string line) nil))))) + ;; The list must contain 3 strings, where the first + ;; is the input prompt, the second is the block + ;; prompt and the last one is the output prompt. The + ;; input prompt is the only one that can't be empty. + (when (and (= (length res) 3) + (cl-every #'stringp res) + (not (string= (car res) ""))) + (throw 'prompts res)))) + nil))) + (when (and (not prompts) + python-shell-prompt-detect-failure-warning) + (lwarn + '(python python-shell-prompt-regexp) + :warning + (concat + "Python shell prompts cannot be detected.\n" + "If your emacs session hangs when starting python shells\n" + "recover with `keyboard-quit' and then try fixing the\n" + "interactive flag for your interpreter by adjusting the\n" + "`python-shell-interpreter-interactive-arg' or add regexps\n" + "matching shell prompts in the directory-local friendly vars:\n" + " + `python-shell-prompt-regexp'\n" + " + `python-shell-prompt-block-regexp'\n" + " + `python-shell-prompt-output-regexp'\n" + "Or alternatively in:\n" + " + `python-shell-prompt-input-regexps'\n" + " + `python-shell-prompt-output-regexps'"))) + prompts)))) (defun python-shell-prompt-validate-regexps () "Validate all user provided regexps for prompts. @@ -2181,14 +2258,12 @@ the `buffer-name'." (defun python-shell-calculate-command () "Calculate the string used to execute the inferior Python process." - (let ((exec-path (python-shell-calculate-exec-path))) + (python-shell-with-environment ;; `exec-path' gets tweaked so that virtualenv's specific ;; `python-shell-interpreter' absolute path can be found by ;; `executable-find'. (format "%s %s" - ;; FIXME: Why executable-find? - (shell-quote-argument - (executable-find python-shell-interpreter)) + (shell-quote-argument python-shell-interpreter) python-shell-interpreter-args))) (define-obsolete-function-alias @@ -2205,38 +2280,6 @@ the `buffer-name'." (concat extra path-separator pythonpath) extra))) -(defun python-shell-calculate-process-environment () - "Calculate process environment given `python-shell-virtualenv-root'." - (let ((process-environment (append - python-shell-process-environment - process-environment nil)) - (virtualenv (if python-shell-virtualenv-root - (directory-file-name python-shell-virtualenv-root) - nil))) - (when python-shell-unbuffered - (setenv "PYTHONUNBUFFERED" "1")) - (when python-shell-extra-pythonpaths - (setenv "PYTHONPATH" (python-shell-calculate-pythonpath))) - (if (not virtualenv) - process-environment - (setenv "PYTHONHOME" nil) - (setenv "PATH" (format "%s/bin%s%s" - virtualenv path-separator - (or (getenv "PATH") ""))) - (setenv "VIRTUAL_ENV" virtualenv)) - process-environment)) - -(defun python-shell-calculate-exec-path () - "Calculate exec path given `python-shell-virtualenv-root'." - (let ((path (append - ;; Use nil as the tail so that the list is a full copy, - ;; this is a paranoid safeguard for side-effects. - python-shell-exec-path exec-path nil))) - (if (not python-shell-virtualenv-root) - path - (cons (expand-file-name "bin" python-shell-virtualenv-root) - path)))) - (defvar python-shell--package-depth 10) (defun python-shell-package-enable (directory package) @@ -2561,31 +2604,30 @@ convention for temporary/internal buffers, and also makes sure the user is not queried for confirmation when the process is killed." (save-excursion - (let* ((proc-buffer-name - (format (if (not internal) "*%s*" " *%s*") proc-name)) - (process-environment (python-shell-calculate-process-environment)) - (exec-path (python-shell-calculate-exec-path))) - (when (not (comint-check-proc proc-buffer-name)) - (let* ((cmdlist (split-string-and-unquote cmd)) - (interpreter (car cmdlist)) - (args (cdr cmdlist)) - (buffer (apply #'make-comint-in-buffer proc-name proc-buffer-name - interpreter nil args)) - (python-shell--parent-buffer (current-buffer)) - (process (get-buffer-process buffer)) - ;; Users can override the interpreter and args - ;; interactively when calling `run-python', let-binding - ;; these allows to have the new right values in all - ;; setup code that is done in `inferior-python-mode', - ;; which is important, especially for prompt detection. - (python-shell--interpreter interpreter) - (python-shell--interpreter-args - (mapconcat #'identity args " "))) - (with-current-buffer buffer - (inferior-python-mode)) - (when show (display-buffer buffer)) - (and internal (set-process-query-on-exit-flag process nil)))) - proc-buffer-name))) + (python-shell-with-environment + (let* ((proc-buffer-name + (format (if (not internal) "*%s*" " *%s*") proc-name))) + (when (not (comint-check-proc proc-buffer-name)) + (let* ((cmdlist (split-string-and-unquote cmd)) + (interpreter (car cmdlist)) + (args (cdr cmdlist)) + (buffer (apply #'make-comint-in-buffer proc-name proc-buffer-name + interpreter nil args)) + (python-shell--parent-buffer (current-buffer)) + (process (get-buffer-process buffer)) + ;; Users can override the interpreter and args + ;; interactively when calling `run-python', let-binding + ;; these allows to have the new right values in all + ;; setup code that is done in `inferior-python-mode', + ;; which is important, especially for prompt detection. + (python-shell--interpreter interpreter) + (python-shell--interpreter-args + (mapconcat #'identity args " "))) + (with-current-buffer buffer + (inferior-python-mode)) + (when show (display-buffer buffer)) + (and internal (set-process-query-on-exit-flag process nil)))) + proc-buffer-name)))) ;;;###autoload (defun run-python (&optional cmd dedicated show) @@ -3984,8 +4026,7 @@ See `python-check-command' for the default." ""))))))) (setq python-check-custom-command command) (save-some-buffers (not compilation-ask-about-save) nil) - (let ((process-environment (python-shell-calculate-process-environment)) - (exec-path (python-shell-calculate-exec-path))) + (python-shell-with-environment (compilation-start command nil (lambda (_modename) (format python-check-buffer-name command)))))