commit 20cca4738aae1e90c6ca7770135fc2b30c08e0f3 (HEAD, refs/remotes/origin/master) Author: Glenn Morris Date: Mon May 11 23:51:58 2015 -0700 * lisp/url/url-handlers.el (url-file-name-completion) (url-file-name-all-completions): Silence compiler. diff --git a/lisp/url/url-handlers.el b/lisp/url/url-handlers.el index ff3eafd..001a783 100644 --- a/lisp/url/url-handlers.el +++ b/lisp/url/url-handlers.el @@ -344,14 +344,14 @@ They count bytes from the beginning of the body." (put 'insert-file-contents 'url-file-handlers 'url-insert-file-contents) -(defun url-file-name-completion (url directory &optional predicate) +(defun url-file-name-completion (url _directory &optional _predicate) ;; Even if it's not implemented, it's not an error to ask for completion, ;; in case it's available (bug#14806). ;; (error "Unimplemented") url) (put 'file-name-completion 'url-file-handlers 'url-file-name-completion) -(defun url-file-name-all-completions (file directory) +(defun url-file-name-all-completions (_file _directory) ;; Even if it's not implemented, it's not an error to ask for completion, ;; in case it's available (bug#14806). ;; (error "Unimplemented") commit f2941a78d2383f00ba3f7a48076ea0586b5abec6 Author: Glenn Morris Date: Mon May 11 23:50:08 2015 -0700 * lisp/emacs-lisp/chart.el (chart-axis-draw): Replace obsolete alias. diff --git a/lisp/emacs-lisp/chart.el b/lisp/emacs-lisp/chart.el index 851b3bf..0660125 100644 --- a/lisp/emacs-lisp/chart.el +++ b/lisp/emacs-lisp/chart.el @@ -280,7 +280,7 @@ START and END represent the boundary." "Draw axis information based upon a range to be spread along the edge. A is the chart to draw. DIR is the direction. MARGIN, ZONE, START, and END specify restrictions in chart space." - (call-next-method) + (cl-call-next-method) ;; We prefer about 5 spaces between each value (let* ((i (car (oref a bounds))) (e (cdr (oref a bounds))) @@ -333,7 +333,7 @@ Automatically compensates for direction." "Draw axis information based upon A range to be spread along the edge. Optional argument DIR is the direction of the chart. Optional arguments MARGIN, ZONE, START and END specify boundaries of the drawing." - (call-next-method) + (cl-call-next-method) ;; We prefer about 5 spaces between each value (let* ((i 0) (s (oref a items)) commit 3903564ed39bd853bc3aaf61457594dfa285f743 Author: Glenn Morris Date: Mon May 11 23:46:40 2015 -0700 * lisp/play/dunnet.el (dun-dos-boot-msg): Fix time. (Bug#20554) diff --git a/lisp/play/dunnet.el b/lisp/play/dunnet.el index 2f4536c..877e5db 100644 --- a/lisp/play/dunnet.el +++ b/lisp/play/dunnet.el @@ -3099,7 +3099,7 @@ File not found"))) (defun dun-dos-boot-msg () (sleep-for 3) (dun-mprinc "Current time is ") - (dun-mprincl (substring (current-time-string) 12 20)) + (dun-mprincl (format-time-string "%H:%M:%S")) (dun-mprinc "Enter new time: ") (dun-read-line) (if (not dun-batch-mode) commit d1b74200dad00cea845037064dc8b5d50db35dd2 Author: Stefan Monnier Date: Tue May 12 00:10:38 2015 -0400 * lisp/emacs-lisp/cl-generic.el: Add dispatch on &context arguments (cl--generic-mandatory-args): Remove. (cl--generic-split-args): New function. (cl-generic-define, cl--generic-lambda): Use it. (cl-generic-define-method): Use it as well, and add support for context args. (cl--generic-get-dispatcher): Handle &context dispatch. (cl--generic-cache-miss): `dispatch-arg' can now be a context expression. (cl--generic-dispatchers): Pre-fill. * test/automated/cl-generic-tests.el (sm-generic-test-12-context): New test. diff --git a/lisp/emacs-lisp/cl-generic.el b/lisp/emacs-lisp/cl-generic.el index fb11a3e..f6595d3 100644 --- a/lisp/emacs-lisp/cl-generic.el +++ b/lisp/emacs-lisp/cl-generic.el @@ -54,6 +54,15 @@ ;; - The standard method combination supports ":extra STRING" qualifiers ;; which simply allows adding more methods for the same ;; specializers&qualifiers. +;; - Methods can dispatch on the context. For that, a method needs to specify +;; context arguments, introduced by `&context' (which need to come right +;; after the mandatory arguments and before anything like +;; &optional/&rest/&key). Each context argument is given as (EXP SPECIALIZER) +;; which means that EXP is taken as an expression which computes some context +;; and this value is then used to dispatch. +;; E.g. (foo &context (major-mode (eql c-mode))) is an arglist specifying +;; that this method will only be applicable when `major-mode' has value +;; `c-mode'. ;; Efficiency considerations: overall, I've made an effort to make this fairly ;; efficient for the expected case (e.g. no constant redefinition of methods). @@ -222,17 +231,12 @@ BODY, if present, is used as the body of a default method. ,@(mapcar (lambda (method) `(cl-defmethod ,name ,@method)) (nreverse methods))))) -(defun cl--generic-mandatory-args (args) - (let ((res ())) - (while (not (memq (car args) '(nil &rest &optional &key))) - (push (pop args) res)) - (nreverse res))) - ;;;###autoload (defun cl-generic-define (name args options) - (let ((generic (cl-generic-ensure-function name)) - (mandatory (cl--generic-mandatory-args args)) - (apo (assq :argument-precedence-order options))) + (pcase-let* ((generic (cl-generic-ensure-function name)) + (`(,spec-args . ,_) (cl--generic-split-args args)) + (mandatory (mapcar #'car spec-args)) + (apo (assq :argument-precedence-order options))) (setf (cl--generic-dispatches generic) nil) (when apo (dolist (arg (cdr apo)) @@ -259,52 +263,70 @@ This macro can only be used within the lexical scope of a cl-generic method." (and (memq sexp vars) (not (memq sexp res)) (push sexp res)) res)) - (defun cl--generic-lambda (args body) - "Make the lambda expression for a method with ARGS and BODY." + (defun cl--generic-split-args (args) + "Return (SPEC-ARGS . PLAIN-ARGS)." (let ((plain-args ()) (specializers nil) (mandatory t)) (dolist (arg args) (push (pcase arg ((or '&optional '&rest '&key) (setq mandatory nil) arg) - ((and `(,name . ,type) (guard mandatory)) + ('&context + (unless mandatory + (error "&context not immediately after mandatory args")) + (setq mandatory 'context) nil) + ((let 'nil mandatory) arg) + ((let 'context mandatory) + (unless (consp arg) + (error "Invalid &context arg: %S" arg)) + (push `((&context . ,(car arg)) . ,(cadr arg)) specializers) + nil) + (`(,name . ,type) (push (cons name (car type)) specializers) name) - (_ arg)) + (_ + (push (cons arg t) specializers) + arg)) plain-args)) - (setq plain-args (nreverse plain-args)) - (let ((fun `(cl-function (lambda ,plain-args ,@body))) - (macroenv (cons `(cl-generic-current-method-specializers - . ,(lambda () specializers)) - macroexpand-all-environment))) - (require 'cl-lib) ;Needed to expand `cl-flet' and `cl-function'. - ;; First macroexpand away the cl-function stuff (e.g. &key and - ;; destructuring args, `declare' and whatnot). - (pcase (macroexpand fun macroenv) - (`#'(lambda ,args . ,body) - (let* ((parsed-body (macroexp-parse-body body)) - (cnm (make-symbol "cl--cnm")) - (nmp (make-symbol "cl--nmp")) - (nbody (macroexpand-all - `(cl-flet ((cl-call-next-method ,cnm) - (cl-next-method-p ,nmp)) - ,@(cdr parsed-body)) - macroenv)) - ;; FIXME: Rather than `grep' after the fact, the - ;; macroexpansion should directly set some flag when cnm - ;; is used. - ;; FIXME: Also, optimize the case where call-next-method is - ;; only called with explicit arguments. - (uses-cnm (cl--generic-fgrep (list cnm nmp) nbody))) - (cons (not (not uses-cnm)) - `#'(lambda (,@(if uses-cnm (list cnm)) ,@args) - ,@(car parsed-body) - ,(if (not (memq nmp uses-cnm)) - nbody - `(let ((,nmp (lambda () - (cl--generic-isnot-nnm-p ,cnm)))) - ,nbody)))))) - (f (error "Unexpected macroexpansion result: %S" f))))))) + (cons (nreverse specializers) + (nreverse (delq nil plain-args))))) + + (defun cl--generic-lambda (args body) + "Make the lambda expression for a method with ARGS and BODY." + (pcase-let* ((`(,spec-args . ,plain-args) + (cl--generic-split-args args)) + (fun `(cl-function (lambda ,plain-args ,@body))) + (macroenv (cons `(cl-generic-current-method-specializers + . ,(lambda () spec-args)) + macroexpand-all-environment))) + (require 'cl-lib) ;Needed to expand `cl-flet' and `cl-function'. + ;; First macroexpand away the cl-function stuff (e.g. &key and + ;; destructuring args, `declare' and whatnot). + (pcase (macroexpand fun macroenv) + (`#'(lambda ,args . ,body) + (let* ((parsed-body (macroexp-parse-body body)) + (cnm (make-symbol "cl--cnm")) + (nmp (make-symbol "cl--nmp")) + (nbody (macroexpand-all + `(cl-flet ((cl-call-next-method ,cnm) + (cl-next-method-p ,nmp)) + ,@(cdr parsed-body)) + macroenv)) + ;; FIXME: Rather than `grep' after the fact, the + ;; macroexpansion should directly set some flag when cnm + ;; is used. + ;; FIXME: Also, optimize the case where call-next-method is + ;; only called with explicit arguments. + (uses-cnm (cl--generic-fgrep (list cnm nmp) nbody))) + (cons (not (not uses-cnm)) + `#'(lambda (,@(if uses-cnm (list cnm)) ,@args) + ,@(car parsed-body) + ,(if (not (memq nmp uses-cnm)) + nbody + `(let ((,nmp (lambda () + (cl--generic-isnot-nnm-p ,cnm)))) + ,nbody)))))) + (f (error "Unexpected macroexpansion result: %S" f)))))) ;;;###autoload @@ -375,21 +397,26 @@ which case this method will be invoked when the argument is `eql' to VAL. ;;;###autoload (defun cl-generic-define-method (name qualifiers args uses-cnm function) - (let* ((generic (cl-generic-ensure-function name)) - (mandatory (cl--generic-mandatory-args args)) - (specializers - (mapcar (lambda (arg) (if (consp arg) (cadr arg) t)) mandatory)) - (method (cl--generic-make-method - specializers qualifiers uses-cnm function)) - (mt (cl--generic-method-table generic)) - (me (cl--generic-member-method specializers qualifiers mt)) - (dispatches (cl--generic-dispatches generic)) - (i 0)) - (dolist (specializer specializers) - (let* ((generalizers (cl-generic-generalizers specializer)) - (x (assq i dispatches))) + (pcase-let* + ((generic (cl-generic-ensure-function name)) + (`(,spec-args . ,_) (cl--generic-split-args args)) + (specializers (mapcar (lambda (spec-arg) + (if (eq '&context (car-safe (car spec-arg))) + spec-arg (cdr spec-arg))) + spec-args)) + (method (cl--generic-make-method + specializers qualifiers uses-cnm function)) + (mt (cl--generic-method-table generic)) + (me (cl--generic-member-method specializers qualifiers mt)) + (dispatches (cl--generic-dispatches generic)) + (i 0)) + (dolist (spec-arg spec-args) + (let* ((key (if (eq '&context (car-safe (car spec-arg))) + (car spec-arg) i)) + (generalizers (cl-generic-generalizers (cdr spec-arg))) + (x (assoc key dispatches))) (unless x - (setq x (cons i (cl-generic-generalizers t))) + (setq x (cons key (cl-generic-generalizers t))) (setf (cl--generic-dispatches generic) (setq dispatches (cons x dispatches)))) (dolist (generalizer generalizers) @@ -427,6 +454,7 @@ which case this method will be invoked when the argument is `eql' to VAL. (defun cl--generic-get-dispatcher (dispatch) (cl--generic-with-memoization (gethash dispatch cl--generic-dispatchers) + ;; (message "cl--generic-get-dispatcher (%S)" dispatch) (let* ((dispatch-arg (car dispatch)) (generalizers (cdr dispatch)) (lexical-binding t) @@ -437,13 +465,14 @@ which case this method will be invoked when the argument is `eql' to VAL. 'arg)) generalizers)) (typescodes - (mapcar (lambda (generalizer) - `(funcall ',(cl--generic-generalizer-specializers-function - generalizer) - ,(funcall (cl--generic-generalizer-tagcode-function - generalizer) - 'arg))) - generalizers)) + (mapcar + (lambda (generalizer) + `(funcall ',(cl--generic-generalizer-specializers-function + generalizer) + ,(funcall (cl--generic-generalizer-tagcode-function + generalizer) + 'arg))) + generalizers)) (tag-exp ;; Minor optimization: since this tag-exp is ;; only used to lookup the method-cache, it @@ -452,23 +481,30 @@ which case this method will be invoked when the argument is `eql' to VAL. `(or ,@(if (macroexp-const-p (car (last tagcodes))) (butlast tagcodes) tagcodes))) - (extraargs ())) - (dotimes (_ dispatch-arg) - (push (make-symbol "arg") extraargs)) + (fixedargs '(arg)) + (dispatch-idx dispatch-arg) + (bindings nil)) + (when (eq '&context (car-safe dispatch-arg)) + (setq bindings `((arg ,(cdr dispatch-arg)))) + (setq fixedargs nil) + (setq dispatch-idx 0)) + (dotimes (i dispatch-idx) + (push (make-symbol (format "arg%d" (- dispatch-idx i 1))) fixedargs)) ;; FIXME: For generic functions with a single method (or with 2 methods, ;; one of which always matches), using a tagcode + hash-table is ;; overkill: better just use a `cl-typep' test. (byte-compile `(lambda (generic dispatches-left methods) (let ((method-cache (make-hash-table :test #'eql))) - (lambda (,@extraargs arg &rest args) - (apply (cl--generic-with-memoization - (gethash ,tag-exp method-cache) - (cl--generic-cache-miss - generic ',dispatch-arg dispatches-left methods - ,(if (cdr typescodes) - `(append ,@typescodes) (car typescodes)))) - ,@extraargs arg args)))))))) + (lambda (,@fixedargs &rest args) + (let ,bindings + (apply (cl--generic-with-memoization + (gethash ,tag-exp method-cache) + (cl--generic-cache-miss + generic ',dispatch-arg dispatches-left methods + ,(if (cdr typescodes) + `(append ,@typescodes) (car typescodes)))) + ,@fixedargs args))))))))) (defun cl--generic-make-function (generic) (cl--generic-make-next-function generic @@ -593,8 +629,11 @@ FUN is the function that should be called when METHOD calls dispatch-arg dispatches-left methods-left types) (let ((methods '())) (dolist (method methods-left) - (let* ((specializer (or (nth dispatch-arg - (cl--generic-method-specializers method)) + (let* ((specializer (or (if (integerp dispatch-arg) + (nth dispatch-arg + (cl--generic-method-specializers method)) + (cdr (assoc dispatch-arg + (cl--generic-method-specializers method)))) t)) (m (member specializer types))) (when m @@ -830,6 +869,17 @@ Can only be used from within the lexical body of a primary or around method." 80 (lambda (name) `(gethash (car-safe ,name) cl--generic-head-used)) (lambda (tag) (if (eq (car-safe tag) 'head) (list tag))))) +;; Pre-fill the cl--generic-dispatchers table. +;; We have two copies of `(0 ...)' but we can't share them via `let' because +;; they're not used at the same time (one is compile-time, one is run-time). +(puthash `(0 ,cl--generic-head-generalizer ,cl--generic-t-generalizer) + (eval-when-compile + (unless (fboundp 'cl--generic-get-dispatcher) + (require 'cl-generic)) + (cl--generic-get-dispatcher + `(0 ,cl--generic-head-generalizer ,cl--generic-t-generalizer))) + cl--generic-dispatchers) + (cl-defmethod cl-generic-generalizers :extra "head" (specializer) "Support for the `(head VAL)' specializers." ;; We have to implement `head' here using the :extra qualifier, @@ -948,40 +998,6 @@ Can only be used from within the lexical body of a primary or around method." (list cl--generic-typeof-generalizer))) (cl-call-next-method))) -;;; Just for kicks: dispatch on major-mode -;; -;; Here's how you'd use it: -;; (cl-defmethod foo ((x (major-mode text-mode)) y z) ...) -;; And then -;; (foo 'major-mode toto titi) -;; -;; FIXME: Better would be to do that via dispatch on an "implicit argument". -;; E.g. (cl-defmethod foo (y z &context (major-mode text-mode)) ...) - -;; (defvar cl--generic-major-modes (make-hash-table :test #'eq)) -;; -;; (add-function :before-until cl-generic-generalizer-function -;; #'cl--generic-major-mode-tagcode) -;; (defun cl--generic-major-mode-tagcode (type name) -;; (if (eq 'major-mode (car-safe type)) -;; `(50 . (if (eq ,name 'major-mode) -;; (cl--generic-with-memoization -;; (gethash major-mode cl--generic-major-modes) -;; `(cl--generic-major-mode . ,major-mode)))))) -;; -;; (add-function :before-until cl-generic-tag-types-function -;; #'cl--generic-major-mode-types) -;; (defun cl--generic-major-mode-types (tag) -;; (when (eq (car-safe tag) 'cl--generic-major-mode) -;; (if (eq tag 'fundamental-mode) '(fundamental-mode t) -;; (let ((types `((major-mode ,(cdr tag))))) -;; (while (get (car types) 'derived-mode-parent) -;; (push (list 'major-mode (get (car types) 'derived-mode-parent)) -;; types)) -;; (unless (eq 'fundamental-mode (car types)) -;; (push '(major-mode fundamental-mode) types)) -;; (nreverse types))))) - ;; Local variables: ;; generated-autoload-file: "cl-loaddefs.el" ;; End: diff --git a/test/automated/cl-generic-tests.el b/test/automated/cl-generic-tests.el index 5194802..a6035d1 100644 --- a/test/automated/cl-generic-tests.el +++ b/test/automated/cl-generic-tests.el @@ -179,5 +179,15 @@ (cl-list* "quatre" (cl-next-method-p) (cl-call-next-method))) (should (equal (cl--generic-1 4 5) '("quatre" t 4 5 nil)))) +(ert-deftest sm-generic-test-12-context () + (cl-defgeneric cl--generic-1 ()) + (cl-defmethod cl--generic-1 (&context (overwrite-mode (eql t))) 'is-t) + (cl-defmethod cl--generic-1 (&context (overwrite-mode (eql nil))) 'is-nil) + (cl-defmethod cl--generic-1 () 'other) + (should (equal (list (let ((overwrite-mode t)) (cl--generic-1)) + (let ((overwrite-mode nil)) (cl--generic-1)) + (let ((overwrite-mode 1)) (cl--generic-1))) + '(is-t is-nil other)))) + (provide 'cl-generic-tests) ;;; cl-generic-tests.el ends here commit f0352ebdf088bea19b44ddb31e94888bc2345a24 Author: Glenn Morris Date: Mon May 11 20:29:06 2015 -0400 * make-dist: Abort if "make ChangeLog" fails. Add "--no-changelog". diff --git a/make-dist b/make-dist index 1b44f90..bc5874e 100755 --- a/make-dist +++ b/make-dist @@ -52,6 +52,7 @@ make_tar=no default_gzip=gzip newer="" with_tests=no +changelog=yes while [ $# -gt 0 ]; do case "$1" in @@ -72,6 +73,9 @@ while [ $# -gt 0 ]; do "--no-check" ) check=no ;; + "--no-changelog" ) + changelog=no + ;; ## This option tells make-dist to make the distribution normally, then ## remove all files older than the given timestamp file. This is useful ## for creating incremental or patch distributions. @@ -115,6 +119,7 @@ while [ $# -gt 0 ]; do echo " --newer=TIME don't include files older than TIME" echo " --no-check don't check for bad file names etc." echo " --no-update don't recompile or do analogous things" + echo " --no-changelog don't generate the top-level ChangeLog" echo " --snapshot same as --clean-up --no-update --tar --no-check" echo " --tar make a tar file" echo " --tests include the test/ directory" @@ -277,11 +282,14 @@ fi echo "Creating top directory: '${tempdir}'" mkdir ${tempdir} -if test -d .git; then - echo "Making top-level ChangeLog" - make ChangeLog CHANGELOG=${tempdir}/ChangeLog -else - echo "No repository, so omitting top-level ChangeLog" +if [ "$changelog" = yes ]; then + if test -d .git; then + echo "Making top-level ChangeLog" + make ChangeLog CHANGELOG=${tempdir}/ChangeLog || \ + { x=$?; echo "make ChangeLog FAILED (try --no-changelog?)" >&2; exit $x; } + else + echo "No repository, so omitting top-level ChangeLog" + fi fi ### We copy in the top-level files before creating the subdirectories in commit 0a21b26c58a241ac41cd12cd10cd605238bb2640 Author: Stefan Monnier Date: Mon May 11 17:23:36 2015 -0400 * lisp/term/xterm.el: Fix xterm-paste handling for rxvt * lisp/term/rxvt.el: Require term/xterm. (rxvt-function-map): Use xterm-rxvt-function-map. (rxvt-standard-colors): Move before first use. (terminal-init-rxvt): Use xterm--push-map and xterm-register-default-colors. (rxvt-rgb-convert-to-16bit, rxvt-register-default-colors): Remove. * lisp/term/xterm.el (xterm-rxvt-function-map): New var. Move shared bindings between rxvt and xterm to it. (xterm-function-map): Use it. Move the xterm-paste binding to xterm-rxvt-function-map (bug#20444). (xterm-standard-colors): Move before first use. (xterm--push-map): New function. (xterm-register-default-colors): Take standard colors as argument. (terminal-init-xterm): Use it. Adjust call to xterm-register-default-colors. diff --git a/lisp/term/rxvt.el b/lisp/term/rxvt.el index fa981c6..c205508 100644 --- a/lisp/term/rxvt.el +++ b/lisp/term/rxvt.el @@ -24,36 +24,21 @@ ;;; Code: +(require 'term/xterm) + (defvar rxvt-function-map (let ((map (make-sparse-keymap))) + (set-keymap-parent map xterm-rxvt-function-map) ;; Set up input-decode-map entries that termcap and terminfo don't know. - (define-key map "\e[A" [up]) - (define-key map "\e[B" [down]) - (define-key map "\e[C" [right]) - (define-key map "\e[D" [left]) - (define-key map "\e[2~" [insert]) - (define-key map "\e[3~" [delete]) - (define-key map "\e[4~" [select]) - (define-key map "\e[5~" [prior]) - (define-key map "\e[6~" [next]) (define-key map "\e[7~" [home]) (define-key map "\e[8~" [end]) - (define-key map "\e[11~" [f1]) - (define-key map "\e[12~" [f2]) - (define-key map "\e[13~" [f3]) - (define-key map "\e[14~" [f4]) - (define-key map "\e[15~" [f5]) - (define-key map "\e[17~" [f6]) - (define-key map "\e[18~" [f7]) - (define-key map "\e[19~" [f8]) - (define-key map "\e[20~" [f9]) - (define-key map "\e[21~" [f10]) ;; The strings emitted by f11 and f12 are the same as the strings ;; emitted by S-f1 and S-f2, so don't define f11 and f12. ;; (define-key rxvt-function-map "\e[23~" [f11]) ;; (define-key rxvt-function-map "\e[24~" [f12]) - (define-key map "\e[29~" [print]) + (define-key map "\e[23~" [S-f1]) + (define-key map "\e[24~" [S-f2]) (define-key map "\e[11^" [C-f1]) (define-key map "\e[12^" [C-f2]) @@ -66,8 +51,6 @@ (define-key map "\e[20^" [C-f9]) (define-key map "\e[21^" [C-f10]) - (define-key map "\e[23~" [S-f1]) - (define-key map "\e[24~" [S-f2]) (define-key map "\e[25~" [S-f3]) (define-key map "\e[26~" [S-f4]) (define-key map "\e[28~" [S-f5]) @@ -99,7 +82,6 @@ (define-key map "\eOa" [C-up]) (define-key map "\eOb" [C-down]) - (define-key map "\e[2;2~" [S-insert]) (define-key map "\e[3$" [S-delete]) (define-key map "\e[5$" [S-prior]) (define-key map "\e[6$" [S-next]) @@ -157,26 +139,6 @@ map) "Keymap of possible alternative meanings for some keys.") -(defun terminal-init-rxvt () - "Terminal initialization function for rxvt." - - (let ((map (copy-keymap rxvt-alternatives-map))) - (set-keymap-parent map (keymap-parent local-function-key-map)) - (set-keymap-parent local-function-key-map map)) - - ;; Use inheritance to let the main keymap override those defaults. - ;; This way we don't override terminfo-derived settings or settings - ;; made in the init file. - (let ((m (copy-keymap rxvt-function-map))) - (set-keymap-parent m (keymap-parent input-decode-map)) - (set-keymap-parent input-decode-map m)) - - ;; Initialize colors and background mode. - (rxvt-register-default-colors) - (rxvt-set-background-mode) - ;; This recomputes all the default faces given the colors we've just set up. - (tty-set-up-initial-frame-faces)) - ;; Set up colors, for those versions of rxvt that support it. (defvar rxvt-standard-colors ;; The names of the colors in the comments taken from the rxvt.1 man @@ -199,93 +161,17 @@ ("brightwhite" 15 (255 255 255))) ; white "Names of 16 standard rxvt colors, their numbers, and RGB values.") -(defun rxvt-rgb-convert-to-16bit (prim) - "Convert an 8-bit primary color value PRIM to a corresponding 16-bit value." - (logior prim (lsh prim 8))) - -(defun rxvt-register-default-colors () - "Register the default set of colors for rxvt or compatible emulator. +(defun terminal-init-rxvt () + "Terminal initialization function for rxvt." -This function registers the number of colors returned by `display-color-cells' -for the currently selected frame." - (let* ((ncolors (display-color-cells)) - (colors rxvt-standard-colors) - (color (car colors))) - (if (> ncolors 0) - ;; Clear the 8 default tty colors registered by startup.el - (tty-color-clear)) - ;; Only register as many colors as are supported by the display. - (while (and (> ncolors 0) colors) - (tty-color-define (car color) (cadr color) - (mapcar 'rxvt-rgb-convert-to-16bit - (car (cddr color)))) - (setq colors (cdr colors) - color (car colors) - ncolors (1- ncolors))) - (when (> ncolors 0) - (cond - ((= ncolors 240) ; 256-color rxvt - ;; 216 non-gray colors first - (let ((r 0) (g 0) (b 0)) - (while (> ncolors 24) - ;; This and other formulas taken from 256colres.pl and - ;; 88colres.pl in the xterm distribution. - (tty-color-define (format "color-%d" (- 256 ncolors)) - (- 256 ncolors) - (mapcar 'rxvt-rgb-convert-to-16bit - (list (if (zerop r) 0 (+ (* r 40) 55)) - (if (zerop g) 0 (+ (* g 40) 55)) - (if (zerop b) 0 (+ (* b 40) 55))))) - (setq b (1+ b)) - (if (> b 5) - (setq g (1+ g) - b 0)) - (if (> g 5) - (setq r (1+ r) - g 0)) - (setq ncolors (1- ncolors)))) - ;; Now the 24 gray colors - (while (> ncolors 0) - (setq color (rxvt-rgb-convert-to-16bit (+ 8 (* (- 24 ncolors) 10)))) - (tty-color-define (format "color-%d" (- 256 ncolors)) - (- 256 ncolors) - (list color color color)) - (setq ncolors (1- ncolors)))) + (xterm--push-map rxvt-alternatives-map local-function-key-map) + (xterm--push-map rxvt-function-map input-decode-map) - ((= ncolors 72) ; rxvt-unicode - ;; 64 non-gray colors - (let ((levels '(0 139 205 255)) - (r 0) (g 0) (b 0)) - (while (> ncolors 8) - (tty-color-define (format "color-%d" (- 88 ncolors)) - (- 88 ncolors) - (mapcar 'rxvt-rgb-convert-to-16bit - (list (nth r levels) - (nth g levels) - (nth b levels)))) - (setq b (1+ b)) - (if (> b 3) - (setq g (1+ g) - b 0)) - (if (> g 3) - (setq r (1+ r) - g 0)) - (setq ncolors (1- ncolors)))) - ;; Now the 8 gray colors - (while (> ncolors 0) - (setq color (rxvt-rgb-convert-to-16bit - (floor - (if (= ncolors 8) - 46.36363636 - (+ (* (- 8 ncolors) 23.18181818) 69.54545454))))) - (tty-color-define (format "color-%d" (- 88 ncolors)) - (- 88 ncolors) - (list color color color)) - (setq ncolors (1- ncolors)))) - (t (error "Unsupported number of rxvt colors (%d)" (+ 16 ncolors))))) - ;; Modifying color mappings means realized faces don't use the - ;; right colors, so clear them. - (clear-face-cache))) + ;; Initialize colors and background mode. + (xterm-register-default-colors rxvt-standard-colors) + (rxvt-set-background-mode) + ;; This recomputes all the default faces given the colors we've just set up. + (tty-set-up-initial-frame-faces)) ;; rxvt puts the default colors into an environment variable ;; COLORFGBG. We use this to set the background mode in a more diff --git a/lisp/term/xterm.el b/lisp/term/xterm.el index 79699c6..667e4ce 100644 --- a/lisp/term/xterm.el +++ b/lisp/term/xterm.el @@ -95,20 +95,50 @@ string bytes that can be copied is 3/4 of this value." (define-key global-map [xterm-paste] #'xterm-paste) -(defvar xterm-function-map +(defvar xterm-rxvt-function-map (let ((map (make-sparse-keymap))) + (define-key map "\e[2~" [insert]) + (define-key map "\e[3~" [delete]) + (define-key map "\e[4~" [select]) + (define-key map "\e[5~" [prior]) + (define-key map "\e[6~" [next]) - ;; xterm from X.org 6.8.2 uses these key definitions. - (define-key map "\eOP" [f1]) - (define-key map "\eOQ" [f2]) - (define-key map "\eOR" [f3]) - (define-key map "\eOS" [f4]) (define-key map "\e[15~" [f5]) (define-key map "\e[17~" [f6]) (define-key map "\e[18~" [f7]) (define-key map "\e[19~" [f8]) (define-key map "\e[20~" [f9]) (define-key map "\e[21~" [f10]) + + (define-key map "\e[2;2~" [S-insert]) + + ;; Other versions of xterm might emit these. + (define-key map "\e[A" [up]) + (define-key map "\e[B" [down]) + (define-key map "\e[C" [right]) + (define-key map "\e[D" [left]) + + (define-key map "\e[11~" [f1]) + (define-key map "\e[12~" [f2]) + (define-key map "\e[13~" [f3]) + (define-key map "\e[14~" [f4]) + + ;; Recognize the start of a bracketed paste sequence. The handler + ;; internally recognizes the end. + (define-key map "\e[200~" [xterm-paste]) + + map) + "Keymap of escape sequences, shared between xterm and rxvt support.") + +(defvar xterm-function-map + (let ((map (make-sparse-keymap))) + (set-keymap-parent map xterm-rxvt-function-map) + + ;; xterm from X.org 6.8.2 uses these key definitions. + (define-key map "\eOP" [f1]) + (define-key map "\eOQ" [f2]) + (define-key map "\eOR" [f3]) + (define-key map "\eOS" [f4]) (define-key map "\e[23~" [f11]) (define-key map "\e[24~" [f12]) @@ -237,12 +267,6 @@ string bytes that can be copied is 3/4 of this value." (define-key map "\e[1;3F" [M-end]) (define-key map "\e[1;3H" [M-home]) - (define-key map "\e[2~" [insert]) - (define-key map "\e[3~" [delete]) - (define-key map "\e[5~" [prior]) - (define-key map "\e[6~" [next]) - - (define-key map "\e[2;2~" [S-insert]) (define-key map "\e[3;2~" [S-delete]) (define-key map "\e[5;2~" [S-prior]) (define-key map "\e[6;2~" [S-next]) @@ -277,7 +301,6 @@ string bytes that can be copied is 3/4 of this value." (define-key map "\e[5;3~" [M-prior]) (define-key map "\e[6;3~" [M-next]) - (define-key map "\e[4~" [select]) (define-key map "\e[29~" [print]) (define-key map "\eOj" [kp-multiply]) @@ -482,10 +505,6 @@ string bytes that can be copied is 3/4 of this value." (format "\e[%d;%du" (nth 1 bind) (nth 0 bind)) (nth 2 bind))) ;; Other versions of xterm might emit these. - (define-key map "\e[A" [up]) - (define-key map "\e[B" [down]) - (define-key map "\e[C" [right]) - (define-key map "\e[D" [left]) (define-key map "\e[1~" [home]) (define-key map "\eO2A" [S-up]) @@ -502,15 +521,6 @@ string bytes that can be copied is 3/4 of this value." (define-key map "\eO5F" [C-end]) (define-key map "\eO5H" [C-home]) - (define-key map "\e[11~" [f1]) - (define-key map "\e[12~" [f2]) - (define-key map "\e[13~" [f3]) - (define-key map "\e[14~" [f4]) - - ;; Recognize the start of a bracketed paste sequence. The handler - ;; internally recognizes the end. - (define-key map "\e[200~" [xterm-paste]) - map) "Function key map overrides for xterm.") @@ -580,6 +590,29 @@ string bytes that can be copied is 3/4 of this value." map) "Keymap of possible alternative meanings for some keys.") +;; Set up colors, for those versions of xterm that support it. +(defvar xterm-standard-colors + ;; The names in the comments taken from XTerm-col.ad in the xterm + ;; distribution, see ftp://dickey.his.com/xterm/. RGB values are + ;; from rgb.txt. + '(("black" 0 ( 0 0 0)) ; black + ("red" 1 (205 0 0)) ; red3 + ("green" 2 ( 0 205 0)) ; green3 + ("yellow" 3 (205 205 0)) ; yellow3 + ("blue" 4 ( 0 0 238)) ; blue2 + ("magenta" 5 (205 0 205)) ; magenta3 + ("cyan" 6 ( 0 205 205)) ; cyan3 + ("white" 7 (229 229 229)) ; gray90 + ("brightblack" 8 (127 127 127)) ; gray50 + ("brightred" 9 (255 0 0)) ; red + ("brightgreen" 10 ( 0 255 0)) ; green + ("brightyellow" 11 (255 255 0)) ; yellow + ("brightblue" 12 (92 92 255)) ; rgb:5c/5c/ff + ("brightmagenta" 13 (255 0 255)) ; magenta + ("brightcyan" 14 ( 0 255 255)) ; cyan + ("brightwhite" 15 (255 255 255))) ; white + "Names of 16 standard xterm/aixterm colors, their numbers, and RGB values.") + (defun xterm--report-background-handler () (let ((str "") chr) @@ -687,6 +720,14 @@ We run the first FUNCTION whose STRING matches the input events." (push (aref (car handler) (setq i (1- i))) unread-command-events))))))) +(defun xterm--push-map (map basemap) + ;; Use inheritance to let the main keymaps override those defaults. + ;; This way we don't override terminfo-derived settings or settings + ;; made in the init file. + (set-keymap-parent + basemap + (make-composed-keymap map (keymap-parent basemap)))) + (defun terminal-init-xterm () "Terminal initialization function for xterm." ;; rxvt terminals sometimes set the TERM variable to "xterm", but @@ -696,19 +737,10 @@ We run the first FUNCTION whose STRING matches the input events." (string-match "\\`rxvt" (getenv "COLORTERM" (selected-frame)))) (tty-run-terminal-initialization (selected-frame) "rxvt") - (let ((map (copy-keymap xterm-alternatives-map))) - (set-keymap-parent map (keymap-parent local-function-key-map)) - (set-keymap-parent local-function-key-map map)) - - (let ((map (copy-keymap xterm-function-map))) + (xterm--push-map xterm-alternatives-map local-function-key-map) + (xterm--push-map xterm-function-map input-decode-map)) - ;; Use inheritance to let the main keymap override those defaults. - ;; This way we don't override terminfo-derived settings or settings - ;; made in the init file. - (set-keymap-parent map (keymap-parent input-decode-map)) - (set-keymap-parent input-decode-map map))) - - (xterm-register-default-colors) + (xterm-register-default-colors xterm-standard-colors) (tty-set-up-initial-frame-faces) (if (eq xterm-extra-capabilities 'check) @@ -807,43 +839,19 @@ hitting screen's max DCS length." "\a" (when screen "\e\\")))))))) -;; Set up colors, for those versions of xterm that support it. -(defvar xterm-standard-colors - ;; The names in the comments taken from XTerm-col.ad in the xterm - ;; distribution, see ftp://dickey.his.com/xterm/. RGB values are - ;; from rgb.txt. - '(("black" 0 ( 0 0 0)) ; black - ("red" 1 (205 0 0)) ; red3 - ("green" 2 ( 0 205 0)) ; green3 - ("yellow" 3 (205 205 0)) ; yellow3 - ("blue" 4 ( 0 0 238)) ; blue2 - ("magenta" 5 (205 0 205)) ; magenta3 - ("cyan" 6 ( 0 205 205)) ; cyan3 - ("white" 7 (229 229 229)) ; gray90 - ("brightblack" 8 (127 127 127)) ; gray50 - ("brightred" 9 (255 0 0)) ; red - ("brightgreen" 10 ( 0 255 0)) ; green - ("brightyellow" 11 (255 255 0)) ; yellow - ("brightblue" 12 (92 92 255)) ; rgb:5c/5c/ff - ("brightmagenta" 13 (255 0 255)) ; magenta - ("brightcyan" 14 ( 0 255 255)) ; cyan - ("brightwhite" 15 (255 255 255))) ; white - "Names of 16 standard xterm/aixterm colors, their numbers, and RGB values.") - (defun xterm-rgb-convert-to-16bit (prim) "Convert an 8-bit primary color value PRIM to a corresponding 16-bit value." (logior prim (lsh prim 8))) -(defun xterm-register-default-colors () +(defun xterm-register-default-colors (colors) "Register the default set of colors for xterm or compatible emulator. This function registers the number of colors returned by `display-color-cells' -for the currently selected frame. The first 16 colors are taken from -`xterm-standard-colors', which see, while the rest are computed assuming +for the currently selected frame. The first (16) colors are taken from +COLORS, which see, while the rest are computed assuming either the 88- or 256-color standard color scheme supported by latest versions of xterm." - (let* ((ncolors (display-color-cells (selected-frame))) - (colors xterm-standard-colors) + (let* ((ncolors (display-color-cells)) (color (car colors))) (if (> ncolors 0) ;; Clear the 8 default tty colors registered by startup.el @@ -851,12 +859,12 @@ versions of xterm." ;; Only register as many colors as are supported by the display. (while (and (> ncolors 0) colors) (tty-color-define (car color) (cadr color) - (mapcar 'xterm-rgb-convert-to-16bit + (mapcar #'xterm-rgb-convert-to-16bit (car (cddr color)))) (setq colors (cdr colors) color (car colors) ncolors (1- ncolors))) - ;; We've exhausted the colors from `xterm-standard-colors'. If there + ;; We've exhausted the colors from `colors'. If there ;; are more colors to support, compute them now. (when (> ncolors 0) (cond @@ -868,7 +876,7 @@ versions of xterm." ;; 88colres.pl in the xterm distribution. (tty-color-define (format "color-%d" (- 256 ncolors)) (- 256 ncolors) - (mapcar 'xterm-rgb-convert-to-16bit + (mapcar #'xterm-rgb-convert-to-16bit (list (if (zerop r) 0 (+ (* r 40) 55)) (if (zerop g) 0 (+ (* g 40) 55)) (if (zerop b) 0 (+ (* b 40) 55))))) @@ -895,7 +903,7 @@ versions of xterm." (while (> ncolors 8) (tty-color-define (format "color-%d" (- 88 ncolors)) (- 88 ncolors) - (mapcar 'xterm-rgb-convert-to-16bit + (mapcar #'xterm-rgb-convert-to-16bit (list (nth r levels) (nth g levels) (nth b levels))))