Path: utzoo!attcan!utgpu!jarvis.csri.toronto.edu!mailrus!csd4.milw.wisc.edu!bbn!gateway!utrccm!ecb
From: ecb@utrccm (ecb)
Newsgroups: comp.emacs
Subject: (none)
Message-ID: <8907201152.AA29788@utrccm.SMC.UTC.COM>
Date: 20 Jul 89 11:52:03 GMT
Sender: news@bbn.COM
Organization: BBN news/mail gateway
Lines: 388

's message of 20 Jul 89 02:41:24 GMT <13069@netnews.upenn.edu>
Subject: execcmd.el and generate.el incompatible


on 20 Jul 89 02:41:24 GMT,
Varun Malhotra said:
Varun> Sender: arpa-unix-emacs-request@bbn.COM
Varun> Source-Info:  From (or Sender) name not authenticated.


Varun> Could someone please e-mail me a copy of execcmd.el?
Varun> (It shows the key bindings when you use execute-extended-command)

Varun> Thanks in advance...
Varun> -Varun

It's at the bottom of this note. I'm posting this to the net cuz I
have a question/request. I've noticed execcmd.el and another recent
posting, generate.el are incompatible. That is, while execcmd.elc
is loaded generate.elc doesn't work. 

Has anyone else noticed (and, hopefully, fixed) this? 

I like using both of these features. The first helps me remember the
key bindings and the second is "teaching" me elisp. I'd very much like
to see them become friends.

I'm including copies of both at the bottom. If no one takes up the
project I'll probably take a stab at it myself eventually, but given
the state of my elisp skills I fear "stab" is more appropriate than I
like to think about.


                Thanks,

			Bud Boman
			United Technologies Research Center
			(203) 727-7128
			ecb@utrccm.smc.utc.com


;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; Replacement for execute-extended-command in GNU Emacs
;;; Copyright (C) 1989 Kyle E. Jones
;;;
;;; This program is free software; you can redistribute it and/or modify
;;; it under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 1, or (at your option)
;;; any later version.
;;;
;;; This program is distributed in the hope that it will be useful,
;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.
;;;
;;; A copy of the GNU General Public License can be obtained from this
;;; program's author (send electronic mail to kyle@cs.odu.edu) or from
;;; the Free Software Foundation, Inc., 675 Mass Ave, Cambridge, MA
;;; 02139, USA.
;;;
;;; Send bug reports to kyle@cs.odu.edu.

;; Save this file as "execcmd.el" in a Lisp directory that Emacs knows about
;; (i.e. via load-path).  Byte-compile it.
;;
;; This package is autoloadable.  Use
;;    (autoload 'execute-extended-command "execcmd" nil t)
;; in your .emacs file.
;;
;; Thanks go to Evan Bigall (evan@plx.UUCP) for the neat idea of having
;; execute-extended-command report the key bindings of the commands it
;; executes.

(defun execute-extended-command (command &optional prefix-argument)
  "Reads an interactive command name, and then calls the command interactively.
If a prefix argument is supplied to this function, it will be passed
appropriately to the command being called.

After the command call returns, the current keymaps are searched for this
command.  If the command is bound to any keys, these are reported in the
echo area."
  (interactive
   (let ((prompt (this-command-keys)))
     (if current-prefix-arg
	 (let* ((i (length prompt))
		(key (substring prompt i)))
	   (while (and (/= i 0) (not (eq (key-binding key) this-command)))
	     (setq i (1- i) key (substring prompt i)))
	   (setq prompt
		 (if (zerop i)
		     (where-is-internal this-command (current-local-map) t)
		   key )
		 prompt (or prompt ":")
		 prompt (concat (meta-key-description prompt) " ")
		 prompt
		 (cond ((consp current-prefix-arg)
			(concat "(" (int-to-string (car current-prefix-arg))
				") " prompt))
		       ((symbolp current-prefix-arg)
			(concat (symbol-name current-prefix-arg) " " prompt))
		       (t
			(concat (int-to-string current-prefix-arg)
				" " prompt)))))
       (if (not (eq (key-binding prompt) this-command))
	   (setq prompt (where-is-internal this-command (current-local-map)
					   t )))
       (setq prompt (concat (meta-key-description prompt) " ")))
     (list (read-command prompt) current-prefix-arg)))
  (setq this-command command)
  (let ((prefix-arg prefix-argument))
    (command-execute command t))
  (if (and (interactive-p) (sit-for 1))
      (let ((keys (append (where-is-internal command (current-local-map)))))
	(if keys
	    (message "%s is on %s" command
		     (mapconcat 'meta-key-description keys " , "))))))

(defun meta-key-description (keys)
  "Works like key-description except that sequences containing
meta-prefix-char that can be expressed meta sequences, are.
E.g. `\"\\ea\" becomes \"M-a\".

If the ambient value of meta-flag in nil, this function is equivalent to
key-description."
  (if (not (and meta-flag (numberp meta-prefix-char)))
      (key-description keys)
    (let (pattern start)
      (setq pattern
	    (if (/= meta-prefix-char ?-)
		(concat (list meta-prefix-char ?[ ?^ meta-prefix-char ?]))
	      "-[^---]"))
      (while (string-match pattern keys start)
	(setq keys
	      (concat
	       (substring keys 0 (match-beginning 0))
	       (char-to-string (logior (aref keys (1- (match-end 0))) 128))
	       (substring keys (match-end 0)))
	      start (match-beginning 0)))
      (key-description keys))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;; module: 	generate.el	
;;;; version: 	2.0
;;;; author: 	Ciaran A Byrne ciaran@gec-rl-hrc.co.uk
;;;; date:	2:Sept:87
;;;;
;;;;;;;;;;;;;;;;;;;; macro lisp expansion ;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;;;
;;;;	user commands:
;;;;		start-generating	- replaces start-kbd-macro ^X(
;;;;		stop-generating		-     "	   end-kbd-macro   ^X)
;;;;		expand-macro		- produces REAL emacs lisp code
;;;;
;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
 
(defmacro caar (x) (list 'car (list 'car x)))
(defmacro cadr (x) (list 'car (list 'cdr x)))
(defmacro caadr (x) (list 'car (list 'car (list 'cdr x))))
(defmacro caddr (x) (list 'car (list 'cdr (list 'cdr x))))
(defmacro cadar (x) (list 'car (list 'cdr (list 'car x))))

(defmacro cdar (x) (list 'cdr (list 'car x)))
(defmacro cddr (l) "" (list 'cdr (list 'cdr l)))
(defmacro cdadr (x) (list 'cdr (list 'car (list 'cdr x))))

;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; replace macro bindings

;;(global-set-key "\^X(" 'start-generating)
;;(global-set-key "\^X)" 'stop-generating)


(defvar gen-history '(first . last) "command-history subsection pair")
(defvar generate-on nil "true if recording commands")


(defun start-generating () "records commands issued
until the command stop-generating is invoked.

The recorded commands can be turned into emacs lisp using
the command expand-macro.

Keystrokes are echoed in the minibuffer to remind you that
you are doing something weird"
 
  (interactive)
  (if generate-on (message "Already generating !")
    (progn
      (setq generate-on t)
      (message "Started generating")
      (rplaca gen-history command-history) ; note beginning of macro
      (unwind-protect
          (command-loop-3)	; run soft command loop
        (stop-generating)))))

(defun stop-generating ()  "Ends command recording.
See also: start-generating
expand-macro"
  
  (interactive)
  (rplacd gen-history  command-history) ; note end of macro
  (message "Stopped generating")
  (setq generate-on nil)
  )

(defun expand-macro (buffer fname doc) "Expands the most recently recorded command sequence
into emacs lisp. Outputs into BUFFER and calls the function NAME
with DOC string.

See also: start-generating, stop-generating"
  
  (interactive "sBuffer for expansion : 
SNew function name : 
sDoc string : ")
  
  (if generate-on (stop-generating))
  
  (let ( (macro (rev-sub-list gen-history)) )	; chop macro out
    
    (get-buffer-create buffer)
    (set-buffer buffer)
    (goto-char (point-max))
    (set-mark (point))
    
    (insert "\n(defun " (symbol-name fname) " () " )   ; function header
    (insert "\"" doc)
    (insert "\nmacroised by " (user-full-name))
    (insert " @ " (current-time-string)  "\"\n")
    (insert "\n(interactive)\n")
    
    (setq standard-output (get-buffer buffer))
    (mapcar 'print macro)
    
    (exchange-point-and-mark)
    
    (mapcar 'delete-matching-lines	; zap useless stuff
            '(   "^$"
                 "start-generating"
                 "stop-generating"
                 "expand-macro"
                 "execute-extended-command nil"
                 ; etc ?
                 )
            )
    
    (narrow-to-region (point) (point-max))
    (emacs-lisp-mode)
    (indent-region (point) (point-max) nil)	; neaten it all up
    
    (mapcar 'merge-multiple-numeric-args
            '(
              previous-line
              next-line
              delete-backward-char
              backward-delete-char-untabify
              backward-kill-word
              kill-word
              forward-char
              backward-char
              ; etc ?
              ))
    
    (goto-char (point-max))
    (insert "\n)\n")
    (widen)
    ))

(defun rev-sub-list (pp) "returns sublist from INTERVAL eg. (beginning . end) ,
where beginning & end point into the same list.
The item at end should be nearer the front of the list.
The car of the result is the element at beginning."
  
  (let ( (stop (car pp))
         (here (cdr pp))
         (result nil)  )
    
    (if (not (memq (car stop) here)) (message "bad arg to rev-sub-list")
      (while (not (eq here stop))
        (setq result (cons (car here) result)) ; build in reverse
        (setq here (cdr here)))
      )
    result))

(defun command-loop-3 () "Mimics the internal command_loop_1,
but locks the RECORD arg to command-execute to true.

Handles universal & prefix arguments, fakes self-insert-command.

Fixes up incremental searches in command-history so that the non-incremental
versions are used instead
"
  (while generate-on			; global flag
    
    (if (null (input-pending-p)) (sit-for 2))
    
    (let* ( (ks (read-key-sequence ""))
            (last-command-char (string-to-char (substring ks -1)))
            (kc (key-binding ks)) )
      
      (cond
       ((eq kc 'universal-argument) (universal-argument))
       
       ((eq kc 'digit-argument) (digit-argument prefix-arg))
       
       ((eq kc 'self-insert-command) (log-self-insert prefix-arg))
       
       ((eq kc 'stop-generating) (stop-generating))
       
       ( t
         (command-execute kc 'record)))
      
      ; now patch search commands
      (cond
       ((eq kc 'isearch-forward)
        (rplaca command-history
                (list 'search-forward search-last-string)))
       
       ((eq kc 'isearch-backward)
        (rplaca command-history
                (list 'search-backward search-last-string)))
       
       ((eq kc 'isearch-forward-regexp)
        (rplaca command-history
                (list 're-search-forward search-last-regexp)))
       
       ((eq kc 'isearch-backward-regexp)
        (rplaca command-history
                (list 're-search-backward search-last-regexp)))
       ))))
 
(defun string-copy (s n) "returns STRING concatted N times"
  (let ( (res "") )
    (while (> n 0)
      (setq res (concat res s))
      (setq n (1- n)))
    res))

(defun log-self-insert (n) "replaces self-insert-command (q.v.)
adds an insert command to command-history,
amalgamates the current insertion with a previous insert command
in command-history, if there is one."
  
  (setq n (if (integerp n) n 1))
  (let ((ins (string-copy (char-to-string last-input-char) n)))
    
    (insert ins)			;do the insertion
    
    ; the comand-history may look like:
    ; ( (insert "t") ... )
    ; if, say, "o" is the last input char, change to just:
    ; (insert "to")
    
    (if (eq 'insert (caar command-history))
        (let* ( (prev (cadar command-history))
                (str (concat prev ins)) )
          
          (rplacd (car command-history) (list str)))
      (setq command-history (cons (list 'insert ins) command-history)))))

(defconst numarg "[ \t]+\\([0-9]+\\)")

(defun merge-multiple-numeric-args (s) "coalesces a pair of lisp lines
invoking the same FUNCTION with a numeric arg so that
a single function with the 2 component args added is used instead.

e.g.
(previous-line 4)
(previous-line 1)	becomes just 	(previous-line 5)
"

(goto-char (point-min))

(if (symbolp s) (setq s (symbol-name s)))

(while
    (re-search-forward 
     (concat s numarg ".*\n[ \t]*(" s numarg) (point-max) t)
  
  (let* ( (md (match-data))
          (arg1 (buffer-substring (nth 2 md) (nth 3 md)))
          (arg2 (buffer-substring (nth 4 md) (nth 5 md)))  
          (newarg (+ (string-to-int arg1) (string-to-int arg2))) )
    
    (delete-region (nth 0 md) (nth 1 md))
    (insert s " " (int-to-string newarg))
    (goto-char (nth 0 md)))))