X-Git-Url: https://code.delx.au/gnu-emacs/blobdiff_plain/ba7908707488f17f1a72491b23e3f42efd10926d..0a40ffd22b8b34c95f45458cd8dce57a61b35d92:/lisp/macros.el

diff --git a/lisp/macros.el b/lisp/macros.el
index 2ff40f81f9..d834dca880 100644
--- a/lisp/macros.el
+++ b/lisp/macros.el
@@ -1,6 +1,6 @@
 ;;; macros.el --- non-primitive commands for keyboard macros.
 
-;; Copyright (C) 1985, 1986, 1987, 1992 Free Software Foundation, Inc.
+;; Copyright (C) 1985, 86, 87, 92, 94, 95 Free Software Foundation, Inc.
 
 ;; Maintainer: FSF
 ;; Keywords: abbrev
@@ -41,6 +41,7 @@ Such a \"function\" cannot be called from Lisp, but it is a valid editor command
       (error "No keyboard macro defined"))
   (and (fboundp symbol)
        (not (stringp (symbol-function symbol)))
+       (not (vectorp (symbol-function symbol)))
        (error "Function %s is already defined and not a keyboard macro."
 	      symbol))
   (fset symbol last-kbd-macro))
@@ -69,32 +70,93 @@ use this command, and then save the file."
       (insert "(fset '"))
     (prin1 macroname (current-buffer))
     (insert "\n   ")
-    (let ((beg (point)) end)
-      (prin1 definition (current-buffer))
-      (setq end (point-marker))
-      (goto-char beg)
-      (while (< (point) end)
-	(let ((char (following-char)))
-	  (cond ((< char 32)
-		 (delete-region (point) (1+ (point)))
-		 (insert "\\C-" (+ 96 char)))
-		((< char 127)
-		 (forward-char 1))
-		((= char 127)
-		 (delete-region (point) (1+ (point)))
-		 (insert "\\C-?"))
-		((< char 160)
-		 (delete-region (point) (1+ (point)))
-		 (insert "\\M-C-" (- char 32)))
-		((< char 255)
-		 (delete-region (point) (1+ (point)))
-		 (insert "\\M-" (- char 128)))
-		((= char 255)
-		 (delete-region (point) (1+ (point)))
-		 (insert "\\M-C-?"))))))
+    (if (stringp definition)
+	(let ((beg (point)) end)
+	  (prin1 definition (current-buffer))
+	  (setq end (point-marker))
+	  (goto-char beg)
+	  (while (< (point) end)
+	    (let ((char (following-char)))
+	      (cond ((= char 0)
+		     (delete-region (point) (1+ (point)))
+		     (insert "\\C-@"))
+		    ((< char 27)
+		     (delete-region (point) (1+ (point)))
+		     (insert "\\C-" (+ 96 char)))
+		    ((= char ?\C-\\)
+		     (delete-region (point) (1+ (point)))
+		     (insert "\\C-\\\\"))
+		    ((< char 32)
+		     (delete-region (point) (1+ (point)))
+		     (insert "\\C-" (+ 64 char)))
+		    ((< char 127)
+		     (forward-char 1))
+		    ((= char 127)
+		     (delete-region (point) (1+ (point)))
+		     (insert "\\C-?"))
+		    ((= char 128)
+		     (delete-region (point) (1+ (point)))
+		     (insert "\\M-\\C-@"))
+		    ((= char (aref "\M-\C-\\" 0))
+		     (delete-region (point) (1+ (point)))
+		     (insert "\\M-\\C-\\\\"))
+		    ((< char 155)
+		     (delete-region (point) (1+ (point)))
+		     (insert "\\M-\\C-" (- char 32)))
+		    ((< char 160)
+		     (delete-region (point) (1+ (point)))
+		     (insert "\\M-\\C-" (- char 64)))
+		    ((= char (aref "\M-\\" 0))
+		     (delete-region (point) (1+ (point)))
+		     (insert "\\M-\\\\"))
+		    ((< char 255)
+		     (delete-region (point) (1+ (point)))
+		     (insert "\\M-" (- char 128)))
+		    ((= char 255)
+		     (delete-region (point) (1+ (point)))
+		     (insert "\\M-\\C-?"))))))
+      (if (vectorp definition)
+	  (let ((len (length definition)) (i 0) char mods)
+	    (while (< i len)
+	      (insert (if (zerop i) ?\[ ?\ ))
+	      (setq char (aref definition i)
+		    i (1+ i))
+	      (cond ((not (numberp char))
+		     (prin1 char (current-buffer)))
+		    (t
+		     (insert "?")
+		     (setq mods (event-modifiers char)
+			   char (event-basic-type char))
+		     (while mods
+		       (cond ((eq (car mods) 'control)
+			      (insert "\\C-"))
+			     ((eq (car mods) 'meta)
+			      (insert "\\M-"))
+			     ((eq (car mods) 'hyper)
+			      (insert "\\H-"))
+			     ((eq (car mods) 'super)
+			      (insert "\\s-"))
+			     ((eq (car mods) 'alt)
+			      (insert "\\A-"))
+			     ((and (eq (car mods) 'shift)
+				   (>= char ?a)
+				   (<= char ?z))
+			      (setq char (upcase char)))
+			     ((eq (car mods) 'shift)
+			      (insert "\\S-")))
+		       (setq mods (cdr mods)))
+		     (cond ((= char ?\\)
+			    (insert "\\\\"))
+			   ((= char 127)
+			    (insert "\\C-?"))
+			   ((< char 127)
+			    (insert char))
+			   (t (insert "\\" (format "%o" char)))))))
+	    (insert ?\]))
+	(prin1 definition (current-buffer))))
     (insert ")\n")
     (if keys
-	(let ((keys (where-is-internal macroname nil)))
+	(let ((keys (where-is-internal macroname '(keymap))))
 	  (while keys
 	    (insert "(global-set-key ")
 	    (prin1 (car keys) (current-buffer))
@@ -128,7 +190,7 @@ Your options are: \\<query-replace-map>
       (let ((loop t)
 	    (msg (substitute-command-keys
 		  "Proceed with macro?\\<query-replace-map>\
- (\\[act], \\[skip], \\[exit], \\[recenter], \\[edit]")))
+ (\\[act], \\[skip], \\[exit], \\[recenter], \\[edit]) ")))
 	(while loop
 	  (let ((key (let ((executing-macro nil)
 			   (defining-kbd-macro nil))
@@ -158,14 +220,16 @@ Your options are: \\<query-replace-map>
 		   (with-output-to-temp-buffer "*Help*"
 		     (princ
 		      (substitute-command-keys
-		       "Specify how to procede with keyboard macro execution.
+		       "Specify how to proceed with keyboard macro execution.
 Possibilities: \\<query-replace-map>
 \\[act]	Finish this iteration normally and continue with the next.
 \\[skip]	Skip the rest of this iteration, and start the next.
 \\[exit]	Stop the macro entirely right now.
 \\[recenter]	Redisplay the screen, then ask again.
-\\[edit]	Enter recursive edit; ask again when you exit from that."))))
-		  )))))))
+\\[edit]	Enter recursive edit; ask again when you exit from that."))
+		     (save-excursion
+		       (set-buffer standard-output)
+		       (help-mode)))))))))))
 
 ;;;###autoload
 (defun apply-macro-to-region-lines (top bottom &optional macro)
@@ -234,7 +298,6 @@ and then select the region of un-tablified names and use
       (set-marker end-marker nil)
       (set-marker next-line-marker nil))))
 
-;;;###autoload
-(define-key ctl-x-map "q" 'kbd-macro-query)
+;;;###autoload (define-key ctl-x-map "q" 'kbd-macro-query)
 
 ;;; macros.el ends here