diff lisp/utils/edmacro.el @ 134:34a5b81f86ba r20-2b1

Import from CVS: tag r20-2b1
author cvs
date Mon, 13 Aug 2007 09:30:11 +0200
parents 7d55a9ba150c
children b980b6286996
line wrap: on
line diff
--- a/lisp/utils/edmacro.el	Mon Aug 13 09:29:37 2007 +0200
+++ b/lisp/utils/edmacro.el	Mon Aug 13 09:30:11 2007 +0200
@@ -5,7 +5,7 @@
 ;; Author: Dave Gillespie <daveg@synaptics.com>
 ;;         Hrvoje Niksic <hniksic@srce.hr>  -- XEmacs port
 ;; Maintainer: Hrvoje Niksic <hniksic@srce.hr>
-;; Version: 3.07
+;; Version: 3.09
 ;; Keywords: abbrev
 
 ;; This file is part of XEmacs.
@@ -54,14 +54,16 @@
 ;; This and `format-kbd-macro' can also be called directly as
 ;; Lisp functions.
 
-;; The `kbd' macro calls `read-kbd-macro', but it is evaluated at
-;; compile-time.  It is good to use in your programs and
-;; initializations, as you needn't know the internal keysym
-;; representation.  For example:
+;; The `kbd' function is a shorter name for `read-kbd-macro'.  It is
+;; good to use in your programs and initializations, as you needn't
+;; know the internal keysym representation.  For example:
 ;;
 ;; (define-key foo-mode-map (kbd "C-c <up>") 'foo-up)
+;;
 ;; is the equivalent of
+;;
 ;; (define-key foo-mode-map [(control ?c) up] 'foo-up)
+;;
 
 ;; Type `C-h m', or see the documentation for `edmacro-mode' below,
 ;; for information about the format of written keyboard macros.
@@ -80,7 +82,7 @@
 ;; Emacs 19.18.)  This package does not work with Emacs 18 or
 ;; Lucid Emacs.
 
-;; But it works with XEmacs.  At least the modified version.  -hniksic
+;; Ported to XEmacs.  -hniksic
 
 ;;; Code:
 
@@ -96,6 +98,11 @@
   "*Non-nil if edit-kbd-macro should leave 8-bit characters intact.
 Default nil means to write characters above \\177 in octal notation.")
 
+(if (fboundp 'mapvector)
+    (defalias 'edmacro-mapvector 'mapvector)
+  (defun edmacro-mapvector (fun seq)
+    (map 'vector fun seq)))
+
 (defvar edmacro-mode-map nil)
 (unless edmacro-mode-map
   (setq edmacro-mode-map (make-sparse-keymap))
@@ -106,6 +113,8 @@
 (defvar edmacro-finish-hook)
 (defvar edmacro-original-buffer)
 
+;; A lot of cruft here, but I got it to work eventually.  Could use
+;; some cleaning up.
 ;;;###autoload
 (defun edit-kbd-macro (keys &optional prefix finish-hook store-hook)
   "Edit a keyboard macro.
@@ -217,10 +226,9 @@
     (setq last-kbd-macro (edmacro-parse-keys (buffer-substring start end)))))
 
 ;;;###autoload
-(defmacro kbd (keys)
+(defun kbd (keys)
   "Convert KEYS to the internal Emacs key representation."
-  `(eval-when-compile
-     (read-kbd-macro ,keys)))
+  (read-kbd-macro keys))
 
 ;;;###autoload
 (defun format-kbd-macro (&optional macro verbose)
@@ -421,52 +429,53 @@
 ;; accepts a vector (but works with a string too).  Vector may contain
 ;; keypress events.      -hniksic
 (defun edmacro-parse-keys (string &optional ignored)
-  (let ((pos 0)
-	(case-fold-search nil)
-	(word-to-sym '(("NUL" . (control space))
-		       ("RET" . return)
-		       ("LFD" . linefeed)
-		       ("TAB" . tab)
-		       ("ESC" . escape)
-		       ("SPC" . space)
-		       ("BS" . backspace)
-		       ("DEL" . delete)))
-	(char-to-word '((?\0 . "NUL")
-			(?\r . "RET")
-			(?\n . "LFD")
-			(?\t . "TAB")
-			(?\e . "ESC")
-			(?\  . "SPC")
-			(?\C-? . "DEL")))
-	(modifier-prefix-alist '(("C" . control)
-				 ("M" . meta)
-				 ("S" . shift)
-				 ("Sh" . shift)
-				 ("A" . alt)
-				 ("H" . hyper)
-				 ("s" . super)))
-	;; string-to-symbol-or-char converter
-	(conv #'(lambda (arg)
-		  (if (= (length arg) 1)
-		      (aref arg 0)
-		    (if (string-match "^<\\([^>]+\\)>$" arg)
-			(setq arg (match-string 1 arg)))
-		    (let ((match (assoc arg word-to-sym)))
-		      (if match
-			  (cdr match)
-			(intern arg))))))
-	(conv-chars #'(lambda (arg)
-			(let ((match (assoc arg char-to-word)))
-			  (if match
-			      (cdr (assoc (cdr match) word-to-sym))
-			    arg))))
-	res)
+  (let* ((pos 0)
+	 (case-fold-search nil)
+	 (word-to-sym '(("NUL" . (control space))
+			("RET" . return)
+			("LFD" . linefeed)
+			("TAB" . tab)
+			("ESC" . escape)
+			("SPC" . space)
+			("BS" . backspace)
+			("DEL" . delete)))
+	 (char-to-word '((?\0 . "NUL")
+			 (?\r . "RET")
+			 (?\n . "LFD")
+			 (?\t . "TAB")
+			 (?\e . "ESC")
+			 (?\  . "SPC")
+			 (?\C-? . "DEL")))
+	 (modifier-prefix-alist '(("C" . control)
+				  ("M" . meta)
+				  ("S" . shift)
+				  ("Sh" . shift)
+				  ("A" . alt)
+				  ("H" . hyper)
+				  ("s" . super)))
+	 ;; string-to-symbol-or-char converter
+	 (conv (lambda (arg)
+		 (if (= (length arg) 1)
+		     (aref arg 0)
+		   (if (string-match "^<\\([^>]+\\)>$" arg)
+		       (setq arg (match-string 1 arg)))
+		   (let ((match (assoc arg word-to-sym)))
+		     (if match
+			 (cdr match)
+			 (intern arg))))))
+	 (conv-chars (lambda (arg)
+		       (let ((match (assoc arg char-to-word)))
+			 (if match
+			     (cdr (assoc (cdr match) word-to-sym))
+			   arg))))
+	 res)
     (while (and (< pos (length string))
 		(string-match "[^ \t\n\f]+" string pos))
       (let ((word (substring string (match-beginning 0) (match-end 0)))
 	    (times 1)
 	    (force-sym nil)
-	    (add nil))
+	    (add nil)
+	    match)
 	(setq pos (match-end 0))
 	(when (string-match "\\([0-9]+\\)\\*." word)
 	  (setq times (string-to-int (substring word 0 (match-end 1))))
@@ -475,7 +484,8 @@
 	  (setq word (match-string 1 word))
 	  (setq force-sym t))
 	(setq match (assoc word word-to-sym))
-	;; Add an element.
+	;; Add an element; `add' holds the list of elements to be
+	;; added.
 	(cond ((string-match "^\\\\[0-7]+" word)
 	       ;; Octal value of character.
 	       (setq add
@@ -496,7 +506,7 @@
 		      (mapcar conv-chars (concat (substring word 2 -2) "\r")))
 		     ))
 	      ((or (equal word "REM") (string-match "^;;" word))
-	       ;; Comment.
+	       ;; Comment (discard to EOL) .
 	       (setq pos (string-match "$" string pos)))
 	      (match
 	       ;; Convert to symbol.
@@ -536,7 +546,7 @@
 	  (loop repeat times do (setq new (append new add)))
 	  (setq add new))
 	(setq res (nconc res add))))
-    (mapvector 'identity res)))
+    (edmacro-mapvector 'identity res)))
 
 (defun edmacro-conv (char-or-sym add-<>)
   (let ((char-to-word '((?\0 . "NUL")
@@ -569,6 +579,9 @@
 		     (cdr found))
 		    ((< char-or-sym 128)
 		     (single-key-description char-or-sym))
+		    ((and edmacro-eight-bits
+			  (>= char-or-sym 128))
+		     (char-to-string char-or-sym))
 		    (t
 		     (format "\\%o" (edmacro-int-char char-or-sym)))))))))
 
@@ -638,15 +651,15 @@
 	(if el
 	    (setq new (nconc new (list el))))
 	(incf cnt))
-      (mapvector 'identity new))))
+      (edmacro-mapvector 'identity new))))
 
 ;; Collapse a list of keys into a list of function keys, where
 ;; applicable.
 (defun edmacro-fkeys (keys)
-  (let (new k)
+  (let (new k lookup)
     (while keys
       (setq k (nconc k (list (car keys))))
-      (setq lookup (lookup-key function-key-map (mapvector 'identity k)))
+      (setq lookup (lookup-key function-key-map (edmacro-mapvector 'identity k)))
       (cond ((vectorp lookup)
 	     (setq new (nconc new (mapcar 'identity lookup)))
 	     (setq k nil))
@@ -674,7 +687,7 @@
       (and (eq verbose 1)
 	   (setq verbose nil))
 
-      ;; Oh come on -- I want a list!  Much easier to process...
+      ;; We prefer a list -- much easier to process...
       (setq macro (mapcar 'identity macro))
       (setq macro (edmacro-fkeys macro))
       (while macro
@@ -682,10 +695,11 @@
 	  (loop do
 		(setq key (nconc key (list (car macro)))
 		      macro (cdr macro)
-		      lookup (lookup-key global-map (mapvector 'identity key)))
+		      lookup (lookup-key global-map (edmacro-mapvector
+						     'identity key)))
 		while
-		(and lookup (not (commandp lookup))))
-	  ;; (lookup-key [?\C-x ?e]) seems to return a vector!
+		(and macro lookup (not (commandp lookup))))
+	  ;; keyboard macro
 	  (if (vectorp lookup)
 	      (setq lookup nil))
 	  (if (and (eq lookup 'self-insert-command)
@@ -751,7 +765,7 @@
       (while (< i (length macro))
 	(when (and (consp (setq ev (aref macro i)))
 		   (not (memq (car ev)	; ha ha
-			      '(hyper super control meta alt control shift))))
+			      '(hyper super meta alt control shift))))
 	  (cond ((equal (cadadr ev) '(menu-bar))
 		 (setq macro (vconcat (edmacro-subseq macro 0 i)
 				      (vector 'menu-bar (car ev))