commit f3c77d11af65f3b319b1784b4c3cf08c51aa7997 (HEAD, refs/remotes/origin/master) Author: Dima Kogan Date: Mon Dec 5 21:42:20 2016 -0800 stash diff --git a/lisp/comint.el b/lisp/comint.el index b23f72ed61..c82c3d09df 100644 --- a/lisp/comint.el +++ b/lisp/comint.el @@ -1879,6 +1879,7 @@ Similarly for Soar, Scheme, etc." (let ((echo-len (- comint-last-input-end comint-last-input-start))) ;; Wait for all input to be echoed: + (while (and (> (+ comint-last-input-end echo-len) (point-max)) (accept-process-output proc) @@ -1890,6 +1891,7 @@ Similarly for Soar, Scheme, etc." ;; (+ comint-last-input-start ;; (- (point-max) comint-last-input-end)) nil comint-last-input-end (point-max))))) + (if (and (<= (+ comint-last-input-end echo-len) (point-max)) @@ -1901,6 +1903,7 @@ Similarly for Soar, Scheme, etc." ;; Certain parts of the text to be deleted may have ;; been mistaken for prompts. We have to prevent ;; problems when `comint-prompt-read-only' is non-nil. + (let ((inhibit-read-only t)) (delete-region comint-last-input-end (+ comint-last-input-end echo-len)) @@ -1909,6 +1912,7 @@ Similarly for Soar, Scheme, etc." (goto-char comint-last-input-end) (comint-update-fence))))))) + ;; This used to call comint-output-filter-functions, ;; but that scrolled the buffer in undesirable ways. (run-hook-with-args 'comint-output-filter-functions ""))))) @@ -2666,7 +2670,7 @@ This command is like `M-.' in bash." (set-marker comint-insert-previous-argument-last-start-pos (point)) ;; Insert the argument. (let ((input-string (comint-previous-input-string 0))) - (when (string-match "[ \t\n]*&" input-string) + (when (string-match "[ \t\n]*&[ \t\n]*$" input-string) ;; strip terminating '&' (setq input-string (substring input-string 0 (match-beginning 0)))) (insert (comint-arguments input-string index index))) diff --git a/lisp/emacs-lisp/debug.el b/lisp/emacs-lisp/debug.el index cb77148c28..faa323f733 100644 --- a/lisp/emacs-lisp/debug.el +++ b/lisp/emacs-lisp/debug.el @@ -816,6 +816,60 @@ Redefining FUNCTION also cancels it." '((depth . -100))) function) +;;;###autoload +;; (defun debug-on-set (symbol) +;; "Request FUNCTION to invoke debugger each time it is called. + +;; When called interactively, prompt for FUNCTION in the minibuffer. + +;; This works by modifying the definition of FUNCTION. If you tell the +;; debugger to continue, FUNCTION's execution proceeds. If FUNCTION is a +;; normal function or a macro written in Lisp, you can also step through +;; its execution. FUNCTION can also be a primitive that is not a special +;; form, in which case stepping is not possible. Break-on-entry for +;; primitive functions only works when that function is called from Lisp. + +;; Use \\[cancel-debug-on-entry] to cancel the effect of this command. +;; Redefining FUNCTION also cancels it." +;; (interactive +;; (let ((v (variable-at-point)) +;; (enable-recursive-minibuffers t) +;; (orig-buffer (current-buffer)) +;; val) +;; (setq val (completing-read +;; (if (symbolp v) +;; (format +;; "Debug on set to symbol (default %s): " v) +;; "Debug on set to symbol: ") +;; #'help--symbol-completion-table +;; (lambda (vv) +;; ;; In case the variable only exists in the buffer +;; ;; the command we switch back to that buffer before +;; ;; we examine the variable. +;; (with-current-buffer orig-buffer +;; (or (get vv 'variable-documentation) +;; (and (boundp vv) (not (keywordp vv)))))) +;; t nil nil +;; (if (symbolp v) (symbol-name v)))) +;; (list (if (equal val "") +;; v (intern val))))) + + + +;; (interactive +;; (let* ((var-default (variable-at-point)) +;; (var (completing-read +;; (if var-default +;; (format "Debug on set to symbol (default %s): " var-default) +;; "Debug on set to symbol: ") +;; nil +;; #'boundp +;; t nil nil (symbol-name var-default)))) +;; (list (if (equal var "") var-default (intern var))))) +;; (advice-add function :before #'debug--implement-debug-on-entry +;; '((depth . -100))) +;; function) + (defun debug--function-list () "List of functions currently set for debug on entry." (let ((funs '())) diff --git a/lisp/shell.el b/lisp/shell.el index c8a8555d63..c7ba64ecf4 100644 --- a/lisp/shell.el +++ b/lisp/shell.el @@ -1000,6 +1000,8 @@ command again." (let ((pt (point)) (regexp (concat + ;; comint-process-echoes is the thing that breaks the + ;; throbber (if comint-process-echoes ;; Skip command echo if the process echoes (concat "\\(" (regexp-quote shell-dirstack-query) "\n\\)") diff --git a/src/data.c b/src/data.c index 8e07bf01b4..26ff994882 100644 --- a/src/data.c +++ b/src/data.c @@ -1304,6 +1304,56 @@ set_internal (Lisp_Object symbol, Lisp_Object newval, Lisp_Object where, default: emacs_abort (); } + + const char* symname = SDATA(sym->name); + + if( EQ(Vwatch_object, symbol) ) + { + static int nest_level = 0; + if(nest_level++ == 0) + { + switch(sym->redirect) + { + case SYMBOL_PLAINVAL: + { + AUTO_STRING (format, "Setting symbol '%s'; redirect: SYMBOL_PLAINVAL"); + CALLN (Fmessage, format, SYMBOL_NAME (symbol)); + break; + } + case SYMBOL_VARALIAS: + { + AUTO_STRING (format, "Setting symbol '%s'; redirect: SYMBOL_VARALIAS"); + CALLN (Fmessage, format, SYMBOL_NAME (symbol)); + break; + } + case SYMBOL_LOCALIZED: + { + AUTO_STRING (format, "Setting symbol '%s'; redirect: SYMBOL_LOCALIZED"); + CALLN (Fmessage, format, SYMBOL_NAME (symbol)); + break; + } + case SYMBOL_FORWARDED: + { + AUTO_STRING (format, "Setting symbol '%s'; redirect: SYMBOL_FORWARDED"); + CALLN (Fmessage, format, SYMBOL_NAME (symbol)); + break; + } + + default: + { + AUTO_STRING (format, "Setting symbol '%s'; redirect: UNKNOWN"); + CALLN (Fmessage, format, SYMBOL_NAME (symbol)); + break; + } + } + } + nest_level--; + } + + + + + start: switch (sym->redirect) { diff --git a/src/fns.c b/src/fns.c index 136a2198c2..9eabc1414f 100644 --- a/src/fns.c +++ b/src/fns.c @@ -5120,6 +5120,10 @@ On some platforms, file selection dialogs are also enabled if this is non-nil. */); use_dialog_box = 1; + DEFVAR_LISP("watch-object", Vwatch_object, + doc: /* Symbol to watch. */); + Vwatch_object = Qnil; + DEFVAR_BOOL ("use-file-dialog", use_file_dialog, doc: /* Non-nil means mouse commands use a file dialog to ask for files. This applies to commands from menus and tool bar buttons even when commit 3c941b900007c9e79c00af0f21d88154f6d8af1a Author: Dima Kogan Date: Fri Nov 25 13:15:12 2016 -0800 comint-get-old-input-default: behavior follows docstring lisp/comint.el (comint-get-old-input-default): Modify behavior to follow docstring: if `comint-use-prompt-regexp' is nil, then return the CURRENT LINE, if point is on an output field. diff --git a/lisp/comint.el b/lisp/comint.el index 830f4ca88f..b23f72ed61 100644 --- a/lisp/comint.el +++ b/lisp/comint.el @@ -2239,10 +2239,7 @@ the current line with any initial string matching the regexp (null (get-char-property (setq bof (field-beginning)) 'field))) (field-string-no-properties bof) (comint-bol) - (buffer-substring-no-properties (point) - (if comint-use-prompt-regexp - (line-end-position) - (field-end)))))) + (buffer-substring-no-properties (point) (line-end-position))))) (defun comint-copy-old-input () "Insert after prompt old input at point as new input to be edited. commit 68e8f4bb4aab3076f6b543864a9116d0a206c8f7 Author: Tom Tromey Date: Thu Jan 19 21:40:38 2017 -0700 css-mode documentation lookup feature * etc/NEWS: Mention new feature. * lisp/textmodes/css-mode.el (css-mode-map): New defvar. (css--mdn-lookup-history): New defvar. (css-lookup-url-format): New defcustom. (css--mdn-property-regexp, css--mdn-completion-list): New defconsts. (css--mdn-after-render, css--mdn-find-symbol, css-lookup-symbol): New defuns. * test/lisp/textmodes/css-mode-tests.el (css-mdn-symbol-guessing): New test. diff --git a/etc/NEWS b/etc/NEWS index e368ff84f8..18ab162bd2 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -613,6 +613,13 @@ HTML tags, classes and IDs using the 'completion-at-point' command. Completion candidates for HTML classes and IDs are retrieved from open HTML mode buffers. +--- +*** CSS mode now binds 'C-h s' to a function that will show +information about a CSS construct (an at-rule, property, pseudo-class, +pseudo-element, with the default being guessed from context). By +default the information is looked up on the Mozilla Developer Network, +but this can be customized using 'css-lookup-url-format'. + +++ ** Emacs now supports character name escape sequences in character and string literals. The syntax variants \N{character name} and diff --git a/lisp/textmodes/css-mode.el b/lisp/textmodes/css-mode.el index c81c3f62e1..19f74daec6 100644 --- a/lisp/textmodes/css-mode.el +++ b/lisp/textmodes/css-mode.el @@ -35,6 +35,7 @@ (require 'seq) (require 'sgml-mode) (require 'smie) +(require 'eww) (defgroup css nil "Cascading Style Sheets (CSS) editing mode." @@ -621,6 +622,12 @@ cannot be completed sensibly: `custom-ident', (modify-syntax-entry ?- "_" st) st)) +(defvar css-mode-map + (let ((map (make-sparse-keymap))) + (define-key map [remap info-lookup-symbol] 'css-lookup-symbol) + map) + "Keymap used in `css-mode'.") + (eval-and-compile (defconst css--uri-re (concat @@ -1087,5 +1094,112 @@ pseudo-elements, pseudo-classes, at-rules, and bang-rules." (setq-local font-lock-defaults (list (scss-font-lock-keywords) nil t))) + + +(defvar css--mdn-lookup-history nil) + +(defcustom css-lookup-url-format + "https://developer.mozilla.org/en-US/docs/Web/CSS/%s?raw¯os" + "Format for a URL where CSS documentation can be found. +The format should include a single \"%s\" substitution. +The name of the CSS property, @-id, pseudo-class, or pseudo-element +to look up will be substituted there." + :version "26.1" + :type 'string + :group 'css) + +(defun css--mdn-after-render () + (setf header-line-format nil) + (goto-char (point-min)) + (let ((window (get-buffer-window (current-buffer) 'visible))) + (when window + (when (re-search-forward "^Summary" nil 'move) + (beginning-of-line) + (set-window-start window (point)))))) + +(defconst css--mdn-symbol-regexp + (concat "\\(" + ;; @-ids. + "\\(@" (regexp-opt css-at-ids) "\\)" + "\\|" + ;; ;; Known properties. + (regexp-opt css-property-ids t) + "\\|" + ;; Pseudo-classes. + "\\(:" (regexp-opt css-pseudo-class-ids) "\\)" + "\\|" + ;; Pseudo-elements with either one or two ":"s. + "\\(::?" (regexp-opt css-pseudo-element-ids) "\\)" + "\\)") + "Regular expression to match the CSS symbol at point.") + +(defconst css--mdn-property-regexp + (concat "\\_<" (regexp-opt css-property-ids t) "\\s-*\\(?:\\=\\|:\\)") + "Regular expression to match a CSS property.") + +(defconst css--mdn-completion-list + (nconc + ;; @-ids. + (mapcar (lambda (atrule) (concat "@" atrule)) css-at-ids) + ;; Pseudo-classes. + (mapcar (lambda (class) (concat ":" class)) css-pseudo-class-ids) + ;; Pseudo-elements with either one or two ":"s. + (mapcar (lambda (elt) (concat ":" elt)) css-pseudo-element-ids) + (mapcar (lambda (elt) (concat "::" elt)) css-pseudo-element-ids) + ;; Properties. + css-property-ids) + "List of all symbols available for lookup via MDN.") + +(defun css--mdn-find-symbol () + "A helper for `css-lookup-symbol' that finds the symbol at point. +Returns the symbol, a string, or nil if none found." + (save-excursion + ;; Skip backward over a word first. + (skip-chars-backward "-[:alnum:] \t") + ;; Now skip ":" or "@" to see if it's a pseudo-element or at-id. + (skip-chars-backward "@:") + (if (looking-at css--mdn-symbol-regexp) + (match-string-no-properties 0) + (let ((bound (save-excursion + (beginning-of-line) + (point)))) + (when (re-search-backward css--mdn-property-regexp bound t) + (match-string-no-properties 1)))))) + +;;;###autoload +(defun css-lookup-symbol (symbol) + "Display the CSS documentation for SYMBOL, as found on MDN. +When this command is used interactively, it picks a default +symbol based on the CSS text before point -- either an @-keyword, +a property name, a pseudo-class, or a pseudo-element, depending +on what is seen near point." + (interactive + (list + (let* ((sym (css--mdn-find-symbol)) + (enable-recursive-minibuffers t) + (value (completing-read + (if sym + (format "Describe CSS symbol (default %s): " sym) + "Describe CSS symbol: ") + css--mdn-completion-list nil nil nil + 'css--mdn-lookup-history sym))) + (if (equal value "") sym value)))) + (when symbol + ;; If we see a single-colon pseudo-element like ":after", turn it + ;; into "::after". + (when (and (eq (aref symbol 0) ?:) + (member (substring symbol 1) css-pseudo-element-ids)) + (setq symbol (concat ":" symbol))) + (let ((url (format css-lookup-url-format symbol)) + (buffer (get-buffer-create "*MDN CSS*"))) + (save-selected-window + ;; Make sure to display the buffer before calling `eww', as + ;; that calls `pop-to-buffer-same-window'. + (switch-to-buffer-other-window buffer) + (with-current-buffer buffer + (eww-mode) + (add-hook 'eww-after-render-hook #'css--mdn-after-render nil t) + (eww url)))))) + (provide 'css-mode) ;;; css-mode.el ends here diff --git a/test/lisp/textmodes/css-mode-tests.el b/test/lisp/textmodes/css-mode-tests.el index 6eb32ea7fc..5372c37a17 100644 --- a/test/lisp/textmodes/css-mode-tests.el +++ b/test/lisp/textmodes/css-mode-tests.el @@ -218,5 +218,20 @@ (should (member "body" completions)) (should-not (member "article" completions))))) +(ert-deftest css-mdn-symbol-guessing () + (dolist (item '(("@med" "ia" "@media") + ("@keyframes " "{" "@keyframes") + ("p::after" "" "::after") + ("p:before" "" ":before") + ("a:v" "isited" ":visited") + ("border-" "color: red" "border-color") + ("border-color: red" ";" "border-color") + ("border-color: red; color: green" ";" "color"))) + (with-temp-buffer + (css-mode) + (insert (nth 0 item)) + (save-excursion (insert (nth 1 item))) + (should (equal (nth 2 item) (css--mdn-find-symbol)))))) + (provide 'css-mode-tests) ;;; css-mode-tests.el ends here commit 77888c88503861197f5e855d18813eb1f6cb4c80 Author: Glenn Morris Date: Mon Jan 30 17:22:32 2017 -0500 edt-mapper: just loading a library should not run code * lisp/emulation/edt-mapper.el (edt-mapper): New function, containing code previously at top-level. * lisp/emulation/edt.el (edt-load-keys): After loading edt-mapper, run edt-mapper function. diff --git a/lisp/emulation/edt-mapper.el b/lisp/emulation/edt-mapper.el index 24a8f039fa..457ad55dd6 100644 --- a/lisp/emulation/edt-mapper.el +++ b/lisp/emulation/edt-mapper.el @@ -57,9 +57,9 @@ ;; Usage: ;; Simply load this file into emacs (version 19 or higher) -;; using the following command. +;; and run the function edt-mapper, using the following command. -;; emacs -q -l edt-mapper.el +;; emacs -q -l edt-mapper -f edt-mapper ;; The "-q" option prevents loading of your init file (commands ;; therein might confuse this program). @@ -96,10 +96,6 @@ ;;; Code: -;; Otherwise it just hangs. This seems preferable. -(if noninteractive - (error "edt-mapper cannot be loaded in batch mode")) - ;;; ;;; Decide Emacs Variant, GNU Emacs or XEmacs (aka Lucid Emacs). ;;; Determine Window System, and X Server Vendor (if appropriate). @@ -124,6 +120,8 @@ ;;; ;;; Key variables ;;; + +;; FIXME some/all of these should be let-bound, not global. (defvar edt-key nil) (defvar edt-enter nil) (defvar edt-return nil) @@ -137,88 +135,116 @@ (defvar edt-save-function-key-map) ;;; -;;; Determine Terminal Type (if appropriate). -;;; - -(if (and edt-window-system (not (eq edt-window-system 'tty))) - (setq edt-term nil) - (setq edt-term (getenv "TERM"))) - -;;; -;;; Implements a workaround for a feature that was added to simple.el. -;;; -;;; Many function keys have no Emacs functions assigned to them by -;;; default. A subset of these are typically assigned functions in the -;;; EDT emulation. This includes all the keypad keys and a some others -;;; like Delete. -;;; -;;; Logic in simple.el maps some of these unassigned function keys to -;;; ordinary typing keys. Where this is the case, a call to -;;; read-key-sequence, below, does not return the name of the function -;;; key pressed by the user but, instead, it returns the name of the -;;; key to which it has been mapped. It needs to know the name of the -;;; key pressed by the user. As a workaround, we assign a function to -;;; each of the unassigned function keys of interest, here. These -;;; assignments override the mapping to other keys and are only -;;; temporary since, when edt-mapper is finished executing, it causes -;;; Emacs to exit. -;;; - -(mapc - (lambda (function-key) - (if (not (lookup-key (current-global-map) function-key)) - (define-key (current-global-map) function-key 'forward-char))) - '([kp-0] [kp-1] [kp-2] [kp-3] [kp-4] - [kp-5] [kp-6] [kp-7] [kp-8] [kp-9] - [kp-space] - [kp-tab] - [kp-enter] - [kp-multiply] - [kp-add] - [kp-separator] - [kp-subtract] - [kp-decimal] - [kp-divide] - [kp-equal] - [backspace] - [delete] - [tab] - [linefeed] - [clear])) - -;;; -;;; Make sure the window is big enough to display the instructions, -;;; except where window cannot be re-sized. -;;; - -(if (and edt-window-system (not (eq edt-window-system 'tty))) - (set-frame-size (selected-frame) 80 36)) - -;;; -;;; Create buffers - Directions and Keys +;;; Key mapping functions ;;; -(if (not (get-buffer "Directions")) (generate-new-buffer "Directions")) -(if (not (get-buffer "Keys")) (generate-new-buffer "Keys")) +(defun edt-map-key (ident descrip) + (interactive) + (if (featurep 'xemacs) + (progn + (setq edt-key-seq (read-key-sequence (format "Press %s%s: " ident descrip))) + (setq edt-key (concat "[" (format "%s" (event-key (aref edt-key-seq 0))) "]")) + (cond ((not (equal edt-key edt-return)) + (set-buffer "Keys") + (insert (format " (\"%s\" . %s)\n" ident edt-key)) + (set-buffer "Directions")) + ;; bogosity to get next prompt to come up, if the user hits ! + ;; check periodically to see if this is still needed... + (t + (set-buffer "Keys") + (insert (format " (\"%s\" . \"\" )\n" ident)) + (set-buffer "Directions")))) + (setq edt-key (read-key-sequence (format "Press %s%s: " ident descrip))) + (cond ((not (equal edt-key edt-return)) + (set-buffer "Keys") + (insert (if (vectorp edt-key) + (format " (\"%s\" . %s)\n" ident edt-key) + (format " (\"%s\" . \"%s\")\n" ident edt-key))) + (set-buffer "Directions")) + ;; bogosity to get next prompt to come up, if the user hits ! + ;; check periodically to see if this is still needed... + (t + (set-buffer "Keys") + (insert (format " (\"%s\" . \"\" )\n" ident)) + (set-buffer "Directions")))) + edt-key) -;;; -;;; Put header in the Keys buffer -;;; -(set-buffer "Keys") -(insert "\ +(defun edt-mapper () + (if noninteractive + (user-error "edt-mapper cannot be loaded in batch mode")) + ;; Determine Terminal Type (if appropriate). + (if (and edt-window-system (not (eq edt-window-system 'tty))) + (setq edt-term nil) + (setq edt-term (getenv "TERM"))) + ;; + ;; Implements a workaround for a feature that was added to simple.el. + ;; + ;; Many function keys have no Emacs functions assigned to them by + ;; default. A subset of these are typically assigned functions in the + ;; EDT emulation. This includes all the keypad keys and a some others + ;; like Delete. + ;; + ;; Logic in simple.el maps some of these unassigned function keys to + ;; ordinary typing keys. Where this is the case, a call to + ;; read-key-sequence, below, does not return the name of the function + ;; key pressed by the user but, instead, it returns the name of the + ;; key to which it has been mapped. It needs to know the name of the + ;; key pressed by the user. As a workaround, we assign a function to + ;; each of the unassigned function keys of interest, here. These + ;; assignments override the mapping to other keys and are only + ;; temporary since, when edt-mapper is finished executing, it causes + ;; Emacs to exit. + ;; + (mapc + (lambda (function-key) + (if (not (lookup-key (current-global-map) function-key)) + (define-key (current-global-map) function-key 'forward-char))) + '([kp-0] [kp-1] [kp-2] [kp-3] [kp-4] + [kp-5] [kp-6] [kp-7] [kp-8] [kp-9] + [kp-space] + [kp-tab] + [kp-enter] + [kp-multiply] + [kp-add] + [kp-separator] + [kp-subtract] + [kp-decimal] + [kp-divide] + [kp-equal] + [backspace] + [delete] + [tab] + [linefeed] + [clear])) + ;; + ;; Make sure the window is big enough to display the instructions, + ;; except where window cannot be re-sized. + ;; + (if (and edt-window-system (not (eq edt-window-system 'tty))) + (set-frame-size (selected-frame) 80 36)) + ;; + ;; Create buffers - Directions and Keys + ;; + (if (not (get-buffer "Directions")) (generate-new-buffer "Directions")) + (if (not (get-buffer "Keys")) (generate-new-buffer "Keys")) + ;; + ;; Put header in the Keys buffer + ;; + (set-buffer "Keys") + (insert "\ ;; ;; Key definitions for the EDT emulation within GNU Emacs ;; -(defconst *EDT-keys* +\(defconst *EDT-keys* '( -") - -;;; -;;; Display directions -;;; -(switch-to-buffer "Directions") -(if (and edt-window-system (not (eq edt-window-system 'tty))) - (insert " + ") + + ;; + ;; Display directions + ;; + (switch-to-buffer "Directions") + (if (and edt-window-system (not (eq edt-window-system 'tty))) + (insert " EDT MAPPER You will be asked to press keys to create a custom mapping (under a @@ -240,7 +266,7 @@ just press RETURN at the prompt. ") - (insert " + (insert " EDT MAPPER You will be asked to press keys to create a custom mapping of your @@ -259,39 +285,39 @@ ")) -(delete-other-windows) - -;;; -;;; Save for future reference. -;;; -;;; For GNU Emacs, running in a Window System, first hide bindings in -;;; function-key-map. -;;; -(cond - ((featurep 'xemacs) - (setq edt-return-seq (read-key-sequence "Hit carriage-return to continue ")) - (setq edt-return (concat "[" (format "%s" (event-key (aref edt-return-seq 0))) "]"))) - (t - (if edt-window-system - (progn - (setq edt-save-function-key-map function-key-map) - (setq function-key-map (make-sparse-keymap)))) - (setq edt-return (read-key-sequence "Hit carriage-return to continue ")))) - -;;; -;;; Remove prefix-key bindings to F1 and F2 in global-map so they can be -;;; bound in the EDT Emulation mode. -;;; -(global-unset-key [f1]) -(global-unset-key [f2]) - -;;; -;;; Display Keypad Diagram and Begin Prompting for Keys -;;; -(set-buffer "Directions") -(delete-region (point-min) (point-max)) -(if (and edt-window-system (not (eq edt-window-system 'tty))) - (insert " + (delete-other-windows) + + ;; + ;; Save for future reference. + ;; + ;; For GNU Emacs, running in a Window System, first hide bindings in + ;; function-key-map. + ;; + (cond + ((featurep 'xemacs) + (setq edt-return-seq (read-key-sequence "Hit carriage-return to continue ")) + (setq edt-return (concat "[" (format "%s" (event-key (aref edt-return-seq 0))) "]"))) + (t + (if edt-window-system + (progn + (setq edt-save-function-key-map function-key-map) + (setq function-key-map (make-sparse-keymap)))) + (setq edt-return (read-key-sequence "Hit carriage-return to continue ")))) + + ;; + ;; Remove prefix-key bindings to F1 and F2 in global-map so they can be + ;; bound in the EDT Emulation mode. + ;; + (global-unset-key [f1]) + (global-unset-key [f2]) + + ;; + ;; Display Keypad Diagram and Begin Prompting for Keys + ;; + (set-buffer "Directions") + (delete-region (point-min) (point-max)) + (if (and edt-window-system (not (eq edt-window-system 'tty))) + (insert " PRESS THE KEY SPECIFIED IN THE MINIBUFFER BELOW. @@ -321,11 +347,11 @@ REMEMBER: JUST PRESS RETURN TO SKIP MAPPING A KEY. ") - (progn - (insert " + (progn + (insert " GENERATING A CUSTOM CONFIGURATION FILE FOR TERMINAL TYPE: ") - (insert (format "%s." edt-term)) - (insert " + (insert (format "%s." edt-term)) + (insert " PRESS THE KEY SPECIFIED IN THE MINIBUFFER BELOW. @@ -347,142 +373,109 @@ REMEMBER: JUST PRESS RETURN TO SKIP MAPPING A KEY."))) -;;; -;;; Key mapping functions -;;; -(defun edt-map-key (ident descrip) - (interactive) - (if (featurep 'xemacs) - (progn - (setq edt-key-seq (read-key-sequence (format "Press %s%s: " ident descrip))) - (setq edt-key (concat "[" (format "%s" (event-key (aref edt-key-seq 0))) "]")) - (cond ((not (equal edt-key edt-return)) - (set-buffer "Keys") - (insert (format " (\"%s\" . %s)\n" ident edt-key)) - (set-buffer "Directions")) - ;; bogosity to get next prompt to come up, if the user hits ! - ;; check periodically to see if this is still needed... - (t - (set-buffer "Keys") - (insert (format " (\"%s\" . \"\" )\n" ident)) - (set-buffer "Directions")))) - (setq edt-key (read-key-sequence (format "Press %s%s: " ident descrip))) - (cond ((not (equal edt-key edt-return)) - (set-buffer "Keys") - (insert (if (vectorp edt-key) - (format " (\"%s\" . %s)\n" ident edt-key) - (format " (\"%s\" . \"%s\")\n" ident edt-key))) - (set-buffer "Directions")) - ;; bogosity to get next prompt to come up, if the user hits ! - ;; check periodically to see if this is still needed... - (t - (set-buffer "Keys") - (insert (format " (\"%s\" . \"\" )\n" ident)) - (set-buffer "Directions")))) - edt-key) -(set-buffer "Keys") -(insert " + (set-buffer "Keys") + (insert " ;; ;; Arrows ;; ") -(set-buffer "Directions") + (set-buffer "Directions") -(edt-map-key "UP" " - The Up Arrow Key") -(edt-map-key "DOWN" " - The Down Arrow Key") -(edt-map-key "LEFT" " - The Left Arrow Key") -(edt-map-key "RIGHT" " - The Right Arrow Key") + (edt-map-key "UP" " - The Up Arrow Key") + (edt-map-key "DOWN" " - The Down Arrow Key") + (edt-map-key "LEFT" " - The Left Arrow Key") + (edt-map-key "RIGHT" " - The Right Arrow Key") -(set-buffer "Keys") -(insert " + (set-buffer "Keys") + (insert " ;; ;; PF keys ;; ") -(set-buffer "Directions") + (set-buffer "Directions") -(edt-map-key "PF1" " - The PF1 (GOLD) Key") -(edt-map-key "PF2" " - The Keypad PF2 Key") -(edt-map-key "PF3" " - The Keypad PF3 Key") -(edt-map-key "PF4" " - The Keypad PF4 Key") + (edt-map-key "PF1" " - The PF1 (GOLD) Key") + (edt-map-key "PF2" " - The Keypad PF2 Key") + (edt-map-key "PF3" " - The Keypad PF3 Key") + (edt-map-key "PF4" " - The Keypad PF4 Key") -(set-buffer "Keys") -(insert " + (set-buffer "Keys") + (insert " ;; ;; KP0-9 KP- KP, KPP and KPE ;; ") -(set-buffer "Directions") - -(edt-map-key "KP0" " - The Keypad 0 Key") -(edt-map-key "KP1" " - The Keypad 1 Key") -(edt-map-key "KP2" " - The Keypad 2 Key") -(edt-map-key "KP3" " - The Keypad 3 Key") -(edt-map-key "KP4" " - The Keypad 4 Key") -(edt-map-key "KP5" " - The Keypad 5 Key") -(edt-map-key "KP6" " - The Keypad 6 Key") -(edt-map-key "KP7" " - The Keypad 7 Key") -(edt-map-key "KP8" " - The Keypad 8 Key") -(edt-map-key "KP9" " - The Keypad 9 Key") -(edt-map-key "KP-" " - The Keypad - Key") -(edt-map-key "KP," " - The Keypad , Key") -(edt-map-key "KPP" " - The Keypad . Key") -(edt-map-key "KPE" " - The Keypad Enter Key") -;; Save the enter key -(setq edt-enter edt-key) -(setq edt-enter-seq edt-key-seq) - - -(set-buffer "Keys") -(insert " + (set-buffer "Directions") + + (edt-map-key "KP0" " - The Keypad 0 Key") + (edt-map-key "KP1" " - The Keypad 1 Key") + (edt-map-key "KP2" " - The Keypad 2 Key") + (edt-map-key "KP3" " - The Keypad 3 Key") + (edt-map-key "KP4" " - The Keypad 4 Key") + (edt-map-key "KP5" " - The Keypad 5 Key") + (edt-map-key "KP6" " - The Keypad 6 Key") + (edt-map-key "KP7" " - The Keypad 7 Key") + (edt-map-key "KP8" " - The Keypad 8 Key") + (edt-map-key "KP9" " - The Keypad 9 Key") + (edt-map-key "KP-" " - The Keypad - Key") + (edt-map-key "KP," " - The Keypad , Key") + (edt-map-key "KPP" " - The Keypad . Key") + (edt-map-key "KPE" " - The Keypad Enter Key") + ;; Save the enter key + (setq edt-enter edt-key) + (setq edt-enter-seq edt-key-seq) + + + (set-buffer "Keys") + (insert " ;; ;; Editing keypad (FIND, INSERT, REMOVE) ;; (SELECT, PREVIOUS, NEXT) ;; ") -(set-buffer "Directions") + (set-buffer "Directions") -(edt-map-key "FIND" " - The Find key on the editing keypad") -(edt-map-key "INSERT" " - The Insert key on the editing keypad") -(edt-map-key "REMOVE" " - The Remove key on the editing keypad") -(edt-map-key "SELECT" " - The Select key on the editing keypad") -(edt-map-key "PREVIOUS" " - The Prev Scr key on the editing keypad") -(edt-map-key "NEXT" " - The Next Scr key on the editing keypad") + (edt-map-key "FIND" " - The Find key on the editing keypad") + (edt-map-key "INSERT" " - The Insert key on the editing keypad") + (edt-map-key "REMOVE" " - The Remove key on the editing keypad") + (edt-map-key "SELECT" " - The Select key on the editing keypad") + (edt-map-key "PREVIOUS" " - The Prev Scr key on the editing keypad") + (edt-map-key "NEXT" " - The Next Scr key on the editing keypad") -(set-buffer "Keys") -(insert " + (set-buffer "Keys") + (insert " ;; ;; F1-14 Help Do F17-F20 ;; ") -(set-buffer "Directions") - -(edt-map-key "F1" " - F1 Function Key") -(edt-map-key "F2" " - F2 Function Key") -(edt-map-key "F3" " - F3 Function Key") -(edt-map-key "F4" " - F4 Function Key") -(edt-map-key "F5" " - F5 Function Key") -(edt-map-key "F6" " - F6 Function Key") -(edt-map-key "F7" " - F7 Function Key") -(edt-map-key "F8" " - F8 Function Key") -(edt-map-key "F9" " - F9 Function Key") -(edt-map-key "F10" " - F10 Function Key") -(edt-map-key "F11" " - F11 Function Key") -(edt-map-key "F12" " - F12 Function Key") -(edt-map-key "F13" " - F13 Function Key") -(edt-map-key "F14" " - F14 Function Key") -(edt-map-key "HELP" " - HELP Function Key") -(edt-map-key "DO" " - DO Function Key") -(edt-map-key "F17" " - F17 Function Key") -(edt-map-key "F18" " - F18 Function Key") -(edt-map-key "F19" " - F19 Function Key") -(edt-map-key "F20" " - F20 Function Key") - -(set-buffer "Directions") -(delete-region (point-min) (point-max)) -(insert " + (set-buffer "Directions") + + (edt-map-key "F1" " - F1 Function Key") + (edt-map-key "F2" " - F2 Function Key") + (edt-map-key "F3" " - F3 Function Key") + (edt-map-key "F4" " - F4 Function Key") + (edt-map-key "F5" " - F5 Function Key") + (edt-map-key "F6" " - F6 Function Key") + (edt-map-key "F7" " - F7 Function Key") + (edt-map-key "F8" " - F8 Function Key") + (edt-map-key "F9" " - F9 Function Key") + (edt-map-key "F10" " - F10 Function Key") + (edt-map-key "F11" " - F11 Function Key") + (edt-map-key "F12" " - F12 Function Key") + (edt-map-key "F13" " - F13 Function Key") + (edt-map-key "F14" " - F14 Function Key") + (edt-map-key "HELP" " - HELP Function Key") + (edt-map-key "DO" " - DO Function Key") + (edt-map-key "F17" " - F17 Function Key") + (edt-map-key "F18" " - F18 Function Key") + (edt-map-key "F19" " - F19 Function Key") + (edt-map-key "F20" " - F20 Function Key") + + (set-buffer "Directions") + (delete-region (point-min) (point-max)) + (insert " ADDITIONAL FUNCTION KEYS Your keyboard may have additional function keys which do not correspond @@ -501,53 +494,53 @@ When you are done, just press RETURN at the \"EDT Key Name:\" prompt. ") -(switch-to-buffer "Directions") -;;; -;;; Add support for extras keys -;;; -(set-buffer "Keys") -(insert "\ + (switch-to-buffer "Directions") + ;; + ;; Add support for extras keys + ;; + (set-buffer "Keys") + (insert "\ ;; ;; Extra Keys ;; ") -;;; -;;; Restore function-key-map. -;;; -(if (and edt-window-system (not (featurep 'xemacs))) - (setq function-key-map edt-save-function-key-map)) -(setq EDT-key-name "") -(while (not - (string-equal (setq EDT-key-name (read-string "EDT Key Name: ")) "")) - (edt-map-key EDT-key-name "")) - -; -; No more keys to add, so wrap up. -; -(set-buffer "Keys") -(insert "\ + ;; + ;; Restore function-key-map. + ;; + (if (and edt-window-system (not (featurep 'xemacs))) + (setq function-key-map edt-save-function-key-map)) + (setq EDT-key-name "") + (while (not + (string-equal (setq EDT-key-name (read-string "EDT Key Name: ")) "")) + (edt-map-key EDT-key-name "")) + + ;; + ;; No more keys to add, so wrap up. + ;; + (set-buffer "Keys") + (insert "\ ) ) ") -;;; -;;; Save the key mapping program -;;; -;;; -;;; Save the key mapping file -;;; -(let ((file (concat - "~/.edt-" (if (featurep 'xemacs) "xemacs" "gnu") - (if edt-term (concat "-" edt-term)) - (if edt-xserver (concat "-" edt-xserver)) - (if edt-window-system (concat "-" (upcase (symbol-name edt-window-system)))) - "-keys"))) - (set-visited-file-name - (read-file-name (format "Save key mapping to file (default %s): " file) nil file))) -(save-buffer) - -(message "That's it! Press any key to exit") -(sit-for 600) -(kill-emacs t) + ;; + ;; Save the key mapping program + ;; + ;; + ;; Save the key mapping file + ;; + (let ((file (concat + "~/.edt-" (if (featurep 'xemacs) "xemacs" "gnu") + (if edt-term (concat "-" edt-term)) + (if edt-xserver (concat "-" edt-xserver)) + (if edt-window-system (concat "-" (upcase (symbol-name edt-window-system)))) + "-keys"))) + (set-visited-file-name + (read-file-name (format "Save key mapping to file (default %s): " file) nil file))) + (save-buffer) + + (message "That's it! Press any key to exit") + (sit-for 600) + (kill-emacs t)) ;;; edt-mapper.el ends here diff --git a/lisp/emulation/edt.el b/lisp/emulation/edt.el index 31f555b032..a6b2d785ac 100644 --- a/lisp/emulation/edt.el +++ b/lisp/emulation/edt.el @@ -1928,6 +1928,8 @@ Optional argument NOT-YES changes the default to negative." ;;; INITIALIZATION COMMANDS. ;;; +(declare-function edt-mapper "edt-mapper" ()) + ;;; ;;; Function used to load LK-201 key mapping file generated by edt-mapper.el. ;;; @@ -1968,7 +1970,7 @@ created." You can do this by quitting Emacs and then invoking Emacs again as follows: - emacs -q -l edt-mapper + emacs -q -l edt-mapper -f edt-mapper [NOTE: If you do nothing out of the ordinary in your init file, and the search for edt-mapper is successful, you can try running it now.] @@ -1983,7 +1985,9 @@ created." (insert (format "Ah yes, there it is, in \n\n %s \n\n" path)) (if (edt-y-or-n-p "Do you want to run it now? ") - (load-file path) + (progn + (load-file path) + (edt-mapper)) (error "EDT Emulation not configured"))) (insert (substitute-command-keys "Nope, I can't seem to find it. :-(\n\n")) commit 5cebfc4495356376cf1c7191bb18aa6c014f8c31 Author: Glenn Morris Date: Mon Jan 30 16:59:37 2017 -0500 mh-compat.el: remove duplicate definition * lisp/mh-e/mh-compat.el (mh-make-obsolete-variable): Remove duplicate definition. diff --git a/lisp/mh-e/mh-compat.el b/lisp/mh-e/mh-compat.el index aae751e8d2..3f3990e869 100644 --- a/lisp/mh-e/mh-compat.el +++ b/lisp/mh-e/mh-compat.el @@ -283,16 +283,6 @@ DOCSTRING arguments." See documentation for `make-obsolete-variable' for a description of the arguments OBSOLETE-NAME, CURRENT-NAME, and perhaps WHEN and ACCESS-TYPE. This macro is used by XEmacs that lacks WHEN and -ACCESS-TYPE arguments." - (if (featurep 'xemacs) - `(make-obsolete-variable ,obsolete-name ,current-name) - `(make-obsolete-variable ,obsolete-name ,current-name ,when ,access-type))) - -(defmacro mh-make-obsolete-variable (obsolete-name current-name &optional when access-type) - "Make the byte-compiler warn that OBSOLETE-NAME is obsolete. -See documentation for `make-obsolete-variable' for a description -of the arguments OBSOLETE-NAME, CURRENT-NAME, and perhaps WHEN -and ACCESS-TYPE. This macro is used by XEmacs that lacks WHEN and ACCESS-TYPE arguments and by Emacs versions that lack ACCESS-TYPE, introduced in Emacs 24." (if (featurep 'xemacs) commit 1056be0b3c6f7f6732bd6f31f78d3a7e1a41f2c2 Author: Paul Eggert Date: Sat Jan 28 16:45:56 2017 -0800 Add delq list arg check * src/fns.c (Fdelq): Check that list is a proper list. This is more compatible with what ‘delete’ does. diff --git a/src/fns.c b/src/fns.c index 0d93f82474..136a2198c2 100644 --- a/src/fns.c +++ b/src/fns.c @@ -1589,6 +1589,7 @@ argument. */) else prev = tail; } + CHECK_LIST_END (tail, list); return list; } commit 499780daef5b9c5d426923ac325b111d3b14267f Author: Stefan Monnier Date: Mon Jan 30 13:06:07 2017 -0500 * lisp/indent.el (indent-region-line-by-line): New function. Extracted from indent-region. (indent-region, indent-region-function): Use it. diff --git a/lisp/indent.el b/lisp/indent.el index db31f0454c..fdd184c799 100644 --- a/lisp/indent.el +++ b/lisp/indent.el @@ -487,9 +487,9 @@ line, but does not move past any whitespace that was explicitly inserted (if (memq (current-justification) '(center right)) (skip-chars-forward " \t"))) -(defvar indent-region-function nil +(defvar indent-region-function #'indent-region-line-by-line "Short cut function to indent region using `indent-according-to-mode'. -A value of nil means really run `indent-according-to-mode' on each line.") +Default is to really run `indent-according-to-mode' on each line.") (defun indent-region (start end &optional column) "Indent each nonblank line in the region. @@ -541,24 +541,26 @@ column to indent to; if it is nil, use one of the three methods above." (funcall indent-region-function start end)) ;; Else, use a default implementation that calls indent-line-function on ;; each line. - (t - (save-excursion - (setq end (copy-marker end)) - (goto-char start) - (let ((pr (unless (minibufferp) - (make-progress-reporter "Indenting region..." (point) end)))) - (while (< (point) end) - (or (and (bolp) (eolp)) - (indent-according-to-mode)) - (forward-line 1) - (and pr (progress-reporter-update pr (point)))) - (and pr (progress-reporter-done pr)) - (move-marker end nil))))) + (t (indent-region-line-by-line start end))) ;; In most cases, reindenting modifies the buffer, but it may also ;; leave it unmodified, in which case we have to deactivate the mark ;; by hand. (setq deactivate-mark t)) +(defun indent-region-line-by-line (start end) + (save-excursion + (setq end (copy-marker end)) + (goto-char start) + (let ((pr (unless (minibufferp) + (make-progress-reporter "Indenting region..." (point) end)))) + (while (< (point) end) + (or (and (bolp) (eolp)) + (indent-according-to-mode)) + (forward-line 1) + (and pr (progress-reporter-update pr (point)))) + (and pr (progress-reporter-done pr)) + (move-marker end nil)))) + (define-obsolete-function-alias 'indent-relative-maybe 'indent-relative-first-indent-point "26.1") commit f74d496478cd57f252817bd7437fe1b7972ce01f Author: Stefan Monnier Date: Mon Jan 30 13:02:18 2017 -0500 * lisp/subr.el (string-make-unibyte, string-make-multibyte): Obsolete. diff --git a/etc/NEWS b/etc/NEWS index 12ff21f39a..e368ff84f8 100644 --- a/etc/NEWS +++ b/etc/NEWS @@ -738,6 +738,7 @@ instead. * Lisp Changes in Emacs 26.1 +** string-(to|as|make)-(uni|multi)byte are now declared obsolete. ** New variable 'while-no-input-ignore-events' which allow setting which special events 'while-no-input' should ignore. It is a list of symbols. diff --git a/lisp/subr.el b/lisp/subr.el index a6ba05c202..a204577ddf 100644 --- a/lisp/subr.el +++ b/lisp/subr.el @@ -1417,8 +1417,10 @@ be a list of the form returned by `event-start' and `event-end'." ;; bug#23850 (make-obsolete 'string-to-unibyte "use `encode-coding-string'." "26.1") (make-obsolete 'string-as-unibyte "use `encode-coding-string'." "26.1") +(make-obsolete 'string-make-unibyte "use `encode-coding-string'." "26.1") (make-obsolete 'string-to-multibyte "use `decode-coding-string'." "26.1") (make-obsolete 'string-as-multibyte "use `decode-coding-string'." "26.1") +(make-obsolete 'string-make-multibyte "use `decode-coding-string'." "26.1") (defun log10 (x) "Return (log X 10), the log base 10 of X." commit 998e1976acc554a35cb7064b7fc7f3b323a30fe6 Author: Eli Zaretskii Date: Mon Jan 30 19:26:02 2017 +0200 More fixes to prevent crashes on C-g * src/fns.c (Fassq, Frassq, Fplist_put): Reset immediate_quit before returning, to avoid crashes in quit. (Bug#25566) diff --git a/src/fns.c b/src/fns.c index 5769eac998..0d93f82474 100644 --- a/src/fns.c +++ b/src/fns.c @@ -1472,7 +1472,7 @@ Elements of LIST that are not conses are ignored. */) immediate_quit = false; return XCAR (tail); } - immediate_quit = true; + immediate_quit = false; CHECK_LIST_END (tail, list); return Qnil; } @@ -1537,7 +1537,7 @@ The value is actually the first element of LIST whose cdr is KEY. */) immediate_quit = false; return XCAR (tail); } - immediate_quit = true; + immediate_quit = false; CHECK_LIST_END (tail, list); return Qnil; } @@ -2090,7 +2090,7 @@ The PLIST is modified by side effects. */) prev = tail; } - immediate_quit = true; + immediate_quit = false; Lisp_Object newcell = Fcons (prop, Fcons (val, NILP (prev) ? plist : XCDR (XCDR (prev)))); if (NILP (prev)) commit ab96c8509736a7ed622916ad2749ff356e520d02 Author: Eli Zaretskii Date: Mon Jan 30 19:08:57 2017 +0200 Avoid crashes on C-g in TTY sessions * src/keyboard.c (handle_interrupt): Don't quit if waiting_for_input is set, as doing that is "unsafe": it will abort. (Bug#25566) diff --git a/src/keyboard.c b/src/keyboard.c index d41603b2e5..0c04d95304 100644 --- a/src/keyboard.c +++ b/src/keyboard.c @@ -10448,7 +10448,7 @@ handle_interrupt (bool in_signal_handler) /* If executing a function that wants to be interrupted out of and the user has not deferred quitting by binding `inhibit-quit' then quit right away. */ - if (immediate_quit && NILP (Vinhibit_quit)) + if (immediate_quit && NILP (Vinhibit_quit) && !waiting_for_input) { struct gl_state_s saved; commit 9c4dfdd1af9f97c6a8d7e922b68a39052116790c Author: Vibhav Pant Date: Mon Jan 30 12:03:23 2017 +0530 Fix hash tables not being purified correctly. * src/alloc.c (purecopy_hash_table) New function, makes a copy of the given hash table in pure storage. Add new struct `pinned_object' and `pinned_objects' linked list for pinning objects. (Fpurecopy) Allow purifying hash tables (purecopy) Pin hash tables that are either weak or not declared with `:purecopy t`, use purecopy_hash_table otherwise. (marked_pinned_objects) New function, marks all objects in pinned_objects. (garbage_collect_1) Use it. Mark all pinned objects before sweeping. * src/lisp.h Add new field `pure' to struct `Lisp_Hash_Table'. * src/fns.c: Add `purecopy' parameter to hash tables. (Fmake_hash_table): Check for a `:purecopy PURECOPY' argument, pass it to make_hash_table. (make_hash_table): Add `pure' parameter, set h->pure to it. (Fclrhash, Fremhash, Fputhash): Enforce that the table is impure with CHECK_IMPURE. * src/lread.c: (read1) Parse for `purecopy' parameter while reading hash tables. * src/print.c: (print_object) add the `purecopy' parameter while printing hash tables. * src/category.c, src/emacs-module.c, src/image.c, src/profiler.c, src/xterm.c: Use new (make_hash_table). diff --git a/src/alloc.c b/src/alloc.c index f7b6515f4e..dd2b688f91 100644 --- a/src/alloc.c +++ b/src/alloc.c @@ -5434,6 +5434,37 @@ make_pure_vector (ptrdiff_t len) return new; } +/* Copy all contents and parameters of TABLE to a new table allocated + from pure space, return the purified table. */ +static struct Lisp_Hash_Table * +purecopy_hash_table (struct Lisp_Hash_Table *table) { + eassert (NILP (table->weak)); + eassert (!NILP (table->pure)); + + struct Lisp_Hash_Table *pure = pure_alloc (sizeof *pure, Lisp_Vectorlike); + struct hash_table_test pure_test = table->test; + + /* Purecopy the hash table test. */ + pure_test.name = purecopy (table->test.name); + pure_test.user_hash_function = purecopy (table->test.user_hash_function); + pure_test.user_cmp_function = purecopy (table->test.user_cmp_function); + + pure->test = pure_test; + pure->header = table->header; + pure->weak = purecopy (Qnil); + pure->rehash_size = purecopy (table->rehash_size); + pure->rehash_threshold = purecopy (table->rehash_threshold); + pure->hash = purecopy (table->hash); + pure->next = purecopy (table->next); + pure->next_free = purecopy (table->next_free); + pure->index = purecopy (table->index); + pure->count = table->count; + pure->key_and_value = purecopy (table->key_and_value); + pure->pure = purecopy (table->pure); + + return pure; +} + DEFUN ("purecopy", Fpurecopy, Spurecopy, 1, 1, 0, doc: /* Make a copy of object OBJ in pure storage. Recursively copies contents of vectors and cons cells. @@ -5442,14 +5473,22 @@ Does not copy symbols. Copies strings without text properties. */) { if (NILP (Vpurify_flag)) return obj; - else if (MARKERP (obj) || OVERLAYP (obj) - || HASH_TABLE_P (obj) || SYMBOLP (obj)) + else if (MARKERP (obj) || OVERLAYP (obj) || SYMBOLP (obj)) /* Can't purify those. */ return obj; else return purecopy (obj); } +struct pinned_object +{ + Lisp_Object object; + struct pinned_object *next; +}; + +/* Pinned objects are marked before every GC cycle. */ +static struct pinned_object *pinned_objects; + static Lisp_Object purecopy (Lisp_Object obj) { @@ -5477,7 +5516,27 @@ purecopy (Lisp_Object obj) obj = make_pure_string (SSDATA (obj), SCHARS (obj), SBYTES (obj), STRING_MULTIBYTE (obj)); - else if (COMPILEDP (obj) || VECTORP (obj) || HASH_TABLE_P (obj)) + else if (HASH_TABLE_P (obj)) + { + struct Lisp_Hash_Table *table = XHASH_TABLE (obj); + /* We cannot purify hash tables which haven't been defined with + :purecopy as non-nil or are weak - they aren't guaranteed to + not change. */ + if (!NILP (table->weak) || NILP (table->pure)) + { + /* Instead, the hash table is added to the list of pinned objects, + and is marked before GC. */ + struct pinned_object *o = xmalloc (sizeof *o); + o->object = obj; + o->next = pinned_objects; + pinned_objects = o; + return obj; /* Don't hash cons it. */ + } + + struct Lisp_Hash_Table *h = purecopy_hash_table (table); + XSET_HASH_TABLE (obj, h); + } + else if (COMPILEDP (obj) || VECTORP (obj)) { struct Lisp_Vector *objp = XVECTOR (obj); ptrdiff_t nbytes = vector_nbytes (objp); @@ -5694,6 +5753,16 @@ compact_undo_list (Lisp_Object list) } static void +mark_pinned_objects (void) +{ + struct pinned_object *pobj; + for (pobj = pinned_objects; pobj; pobj = pobj->next) + { + mark_object (pobj->object); + } +} + +static void mark_pinned_symbols (void) { struct symbol_block *sblk; @@ -5813,6 +5882,7 @@ garbage_collect_1 (void *end) for (i = 0; i < staticidx; i++) mark_object (*staticvec[i]); + mark_pinned_objects (); mark_pinned_symbols (); mark_terminals (); mark_kboards (); diff --git a/src/category.c b/src/category.c index e5d261c1cf..ff287a4af3 100644 --- a/src/category.c +++ b/src/category.c @@ -67,7 +67,7 @@ hash_get_category_set (Lisp_Object table, Lisp_Object category_set) make_hash_table (hashtest_equal, make_number (DEFAULT_HASH_SIZE), make_float (DEFAULT_REHASH_SIZE), make_float (DEFAULT_REHASH_THRESHOLD), - Qnil)); + Qnil, Qnil)); h = XHASH_TABLE (XCHAR_TABLE (table)->extras[1]); i = hash_lookup (h, category_set, &hash); if (i >= 0) diff --git a/src/emacs-module.c b/src/emacs-module.c index e22c7dc5b7..69fa5c8e64 100644 --- a/src/emacs-module.c +++ b/src/emacs-module.c @@ -1016,7 +1016,7 @@ syms_of_module (void) = make_hash_table (hashtest_eq, make_number (DEFAULT_HASH_SIZE), make_float (DEFAULT_REHASH_SIZE), make_float (DEFAULT_REHASH_THRESHOLD), - Qnil); + Qnil, Qnil); Funintern (Qmodule_refs_hash, Qnil); DEFSYM (Qmodule_environments, "module-environments"); diff --git a/src/fns.c b/src/fns.c index b8ebfe5b2e..5769eac998 100644 --- a/src/fns.c +++ b/src/fns.c @@ -34,6 +34,7 @@ along with GNU Emacs. If not, see . */ #include "buffer.h" #include "intervals.h" #include "window.h" +#include "puresize.h" static void sort_vector_copy (Lisp_Object, ptrdiff_t, Lisp_Object *restrict, Lisp_Object *restrict); @@ -3750,12 +3751,17 @@ allocate_hash_table (void) (table size) is >= REHASH_THRESHOLD. WEAK specifies the weakness of the table. If non-nil, it must be - one of the symbols `key', `value', `key-or-value', or `key-and-value'. */ + one of the symbols `key', `value', `key-or-value', or `key-and-value'. + + If PURECOPY is non-nil, the table can be copied to pure storage via + `purecopy' when Emacs is being dumped. Such tables can no longer be + changed after purecopy. */ Lisp_Object make_hash_table (struct hash_table_test test, Lisp_Object size, Lisp_Object rehash_size, - Lisp_Object rehash_threshold, Lisp_Object weak) + Lisp_Object rehash_threshold, Lisp_Object weak, + Lisp_Object pure) { struct Lisp_Hash_Table *h; Lisp_Object table; @@ -3796,6 +3802,7 @@ make_hash_table (struct hash_table_test test, h->hash = Fmake_vector (size, Qnil); h->next = Fmake_vector (size, Qnil); h->index = Fmake_vector (make_number (index_size), Qnil); + h->pure = pure; /* Set up the free list. */ for (i = 0; i < sz - 1; ++i) @@ -4460,10 +4467,15 @@ key, value, one of key or value, or both key and value, depending on WEAK. WEAK t is equivalent to `key-and-value'. Default value of WEAK is nil. +:purecopy PURECOPY -- If PURECOPY is non-nil, the table can be copied +to pure storage when Emacs is being dumped, making the contents of the +table read only. Any further changes to purified tables will result +in an error. + usage: (make-hash-table &rest KEYWORD-ARGS) */) (ptrdiff_t nargs, Lisp_Object *args) { - Lisp_Object test, size, rehash_size, rehash_threshold, weak; + Lisp_Object test, size, rehash_size, rehash_threshold, weak, pure; struct hash_table_test testdesc; ptrdiff_t i; USE_SAFE_ALLOCA; @@ -4497,6 +4509,9 @@ usage: (make-hash-table &rest KEYWORD-ARGS) */) testdesc.cmpfn = cmpfn_user_defined; } + /* See if there's a `:purecopy PURECOPY' argument. */ + i = get_key_arg (QCpurecopy, nargs, args, used); + pure = i ? args[i] : Qnil; /* See if there's a `:size SIZE' argument. */ i = get_key_arg (QCsize, nargs, args, used); size = i ? args[i] : Qnil; @@ -4538,7 +4553,8 @@ usage: (make-hash-table &rest KEYWORD-ARGS) */) signal_error ("Invalid argument list", args[i]); SAFE_FREE (); - return make_hash_table (testdesc, size, rehash_size, rehash_threshold, weak); + return make_hash_table (testdesc, size, rehash_size, rehash_threshold, weak, + pure); } @@ -4617,7 +4633,9 @@ DEFUN ("clrhash", Fclrhash, Sclrhash, 1, 1, 0, doc: /* Clear hash table TABLE and return it. */) (Lisp_Object table) { - hash_clear (check_hash_table (table)); + struct Lisp_Hash_Table *h = check_hash_table (table); + CHECK_IMPURE (table, h); + hash_clear (h); /* Be compatible with XEmacs. */ return table; } @@ -4641,9 +4659,10 @@ VALUE. In any case, return VALUE. */) (Lisp_Object key, Lisp_Object value, Lisp_Object table) { struct Lisp_Hash_Table *h = check_hash_table (table); + CHECK_IMPURE (table, h); + ptrdiff_t i; EMACS_UINT hash; - i = hash_lookup (h, key, &hash); if (i >= 0) set_hash_value_slot (h, i, value); @@ -4659,6 +4678,7 @@ DEFUN ("remhash", Fremhash, Sremhash, 2, 2, 0, (Lisp_Object key, Lisp_Object table) { struct Lisp_Hash_Table *h = check_hash_table (table); + CHECK_IMPURE (table, h); hash_remove_from_table (h, key); return Qnil; } @@ -5029,6 +5049,7 @@ syms_of_fns (void) DEFSYM (Qequal, "equal"); DEFSYM (QCtest, ":test"); DEFSYM (QCsize, ":size"); + DEFSYM (QCpurecopy, ":purecopy"); DEFSYM (QCrehash_size, ":rehash-size"); DEFSYM (QCrehash_threshold, ":rehash-threshold"); DEFSYM (QCweakness, ":weakness"); diff --git a/src/image.c b/src/image.c index 39677d2add..ad0143be48 100644 --- a/src/image.c +++ b/src/image.c @@ -4020,7 +4020,7 @@ xpm_make_color_table_h (void (**put_func) (Lisp_Object, const char *, int, return make_hash_table (hashtest_equal, make_number (DEFAULT_HASH_SIZE), make_float (DEFAULT_REHASH_SIZE), make_float (DEFAULT_REHASH_THRESHOLD), - Qnil); + Qnil, Qnil); } static void diff --git a/src/lisp.h b/src/lisp.h index 84d53bb1ee..91c430fe98 100644 --- a/src/lisp.h +++ b/src/lisp.h @@ -1995,6 +1995,10 @@ struct Lisp_Hash_Table hash table size to reduce collisions. */ Lisp_Object index; + /* Non-nil if the table can be purecopied. Any changes the table after + purecopy will result in an error. */ + Lisp_Object pure; + /* Only the fields above are traced normally by the GC. The ones below `count' are special and are either ignored by the GC or traced in a special way (e.g. because of weakness). */ @@ -3364,7 +3368,7 @@ extern void sweep_weak_hash_tables (void); EMACS_UINT hash_string (char const *, ptrdiff_t); EMACS_UINT sxhash (Lisp_Object, int); Lisp_Object make_hash_table (struct hash_table_test, Lisp_Object, Lisp_Object, - Lisp_Object, Lisp_Object); + Lisp_Object, Lisp_Object, Lisp_Object); ptrdiff_t hash_lookup (struct Lisp_Hash_Table *, Lisp_Object, EMACS_UINT *); ptrdiff_t hash_put (struct Lisp_Hash_Table *, Lisp_Object, Lisp_Object, EMACS_UINT); diff --git a/src/lread.c b/src/lread.c index ea2a1d1d85..17806922a8 100644 --- a/src/lread.c +++ b/src/lread.c @@ -2599,7 +2599,7 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) Lisp_Object val = Qnil; /* The size is 2 * number of allowed keywords to make-hash-table. */ - Lisp_Object params[10]; + Lisp_Object params[12]; Lisp_Object ht; Lisp_Object key = Qnil; int param_count = 0; @@ -2636,6 +2636,11 @@ read1 (Lisp_Object readcharfun, int *pch, bool first_in_list) if (!NILP (params[param_count + 1])) param_count += 2; + params[param_count] = QCpurecopy; + params[param_count + 1] = Fplist_get (tmp, Qpurecopy); + if (!NILP (params[param_count + 1])) + param_count += 2; + /* This is the hash table data. */ data = Fplist_get (tmp, Qdata); @@ -4849,6 +4854,7 @@ that are loaded before your customizations are read! */); DEFSYM (Qdata, "data"); DEFSYM (Qtest, "test"); DEFSYM (Qsize, "size"); + DEFSYM (Qpurecopy, "purecopy"); DEFSYM (Qweakness, "weakness"); DEFSYM (Qrehash_size, "rehash-size"); DEFSYM (Qrehash_threshold, "rehash-threshold"); diff --git a/src/print.c b/src/print.c index 36d68a452e..db3d00f51f 100644 --- a/src/print.c +++ b/src/print.c @@ -1818,6 +1818,12 @@ print_object (Lisp_Object obj, Lisp_Object printcharfun, bool escapeflag) print_object (h->rehash_threshold, printcharfun, escapeflag); } + if (!NILP (h->pure)) + { + print_c_string (" purecopy ", printcharfun); + print_object (h->pure, printcharfun, escapeflag); + } + print_c_string (" data ", printcharfun); /* Print the data here as a plist. */ diff --git a/src/profiler.c b/src/profiler.c index 88825bebdb..a223a7e7c0 100644 --- a/src/profiler.c +++ b/src/profiler.c @@ -48,7 +48,7 @@ make_log (EMACS_INT heap_size, EMACS_INT max_stack_depth) make_number (heap_size), make_float (DEFAULT_REHASH_SIZE), make_float (DEFAULT_REHASH_THRESHOLD), - Qnil); + Qnil, Qnil); struct Lisp_Hash_Table *h = XHASH_TABLE (log); /* What is special about our hash-tables is that the keys are pre-filled diff --git a/src/xterm.c b/src/xterm.c index 80cf8ce191..38229a5f31 100644 --- a/src/xterm.c +++ b/src/xterm.c @@ -12877,7 +12877,7 @@ keysyms. The default is nil, which is the same as `super'. */); Vx_keysym_table = make_hash_table (hashtest_eql, make_number (900), make_float (DEFAULT_REHASH_SIZE), make_float (DEFAULT_REHASH_THRESHOLD), - Qnil); + Qnil, Qnil); DEFVAR_BOOL ("x-frame-normalize-before-maximize", x_frame_normalize_before_maximize,