🚀 go-pugleaf

In GNU Emacs 19.25.1 of Wed Aug 31 1994 on lks (sparc-sun-sunos)

To reproduce:

 1) load the attached file
 2) bring up gnus
 3) click the right mouse button in Newsgroup buffer. 
    A menu will popup. click left off to the side to dismiss it. 
 4) place insertion cursor on a news group and press space bar. 
 5) In summary buffer press the right mouse button again. Emacs will 
    seg fault.

---------------------------------- Snip Here -----------------------
;;   -*- Mode: emacs-lisp -*-
;; 
;; Automatic generation of mode specific popup and pulldown menus
;; 
;; Copyright (C) 1992,1993 Guido Bosch <Guido.Bosch@loria.fr>

;; This file is written in GNU Emacs Lisp, but not (yet) part of GNU Emacs.

;; The software contained in this file 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 2, or (at your option) any later version.

;; GNU Emacs 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.

;; You should have received a copy of the GNU General Public License
;; along with GNU Emacs; see the file COPYING.  If not, write to
;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.
;; 
;; Please send bugs and comments to the author. 
;;
;; <DISCLAIMER>
;; This program is still under development.  Neither the author nor
;; CRIN-INRIA accepts responsibility to anyone for the consequences of
;; using it or for whether it serves any particular purpose or works
;; at all.


; Change History
; 
; $Log: mode-menu.el,v $
; Revision 1.9  1994/09/26  13:25:23  molli
; Remove procedure to insert "command glossary" in menu help
;
; Revision 1.8  1993/07/12  17:17:21  bosch
;  Customization variables for mode menu key bindings added:
; `mode-menu-button' and `mode-menu-recompute-button'.  Function
; `mode-menu' modified. It is added to the `find-file-hooks' if the user
; option `mode-menu-add-to-menubar' is non-nil. This allows mode menus
; to be automatically added to the menubar whenever a new file is
; visited, even if there is no mouse button that invokes it. This
; behavior can be controlled by the variable `mode-menu-add-to-menubar'.
;
; Revision 1.7  1993/02/04  15:08:57  bosch
; cl dependency removed. Parent keymaps are checked now. New user
; option: `mode-menu-compute-global-map-menu'.  New feature: Command
; Glossay (available from the "Help" menu, see the introduction for
; details. Minor bug fixes.
;
; Revision 1.6  1993/02/02  10:55:46  bosch
; First step towards a cl independent version: converted two `do's in
; `while's. `mode-menu-load-hook' added.
;
; Revision 1.5  1993/01/20  13:12:05  bosch
; Command `mode-menu-recompute' on meta button3 added.
; Minor bug fixes. Some typos corrected.
;
; Revision 1.4  1992/10/28  20:54:59  bosch
; Example of a personal menu creation added. Made adding of mode menus
; to the menubar customizable. Adding buffer local pulldown menus works
; much better now (function `mode-menu-add-to-menubar'). Command
; `mode-menu-elisp-code' now also generates the mode hook to install
; individualized mode menus. Multiple menu items bug fixed.  Active
; zmacs regions don't disappear any longer when the mode menu pops up.
;
; Revision 1.3  1992/10/26  08:44:56  bosch
; User option `mode-menu-add-to-menubar' added.
;
; Revision 1.2  1992/10/22  19:15:30  bosch
; Variable `mode-menu-add-in-front-of-menubar' added. It determines
; whether a newly created mode menu will go in front or tail position in
; the menubar.
;
; Revision 1.1  1992/10/20  19:45:50  bosch
; Automatic generation of mode specific popup menus.
; For Lucid Emacs version 19.3 (or later).
;
;


;; INSTALLATION:
;; ------------
;; To install, just load it with
;; (require 'mode-menu)
;;   or
;; (load "mode-menu") 
;;
;; It also can be made autoloadable with the following code:
;; (autoload 'mode-menu "mode-menu" nil t)
;; (autoload 'mode-menu-elisp-code "mode-menu" nil t)
;; (autoload 'mode-menu-glossary "mode-menu" nil t)
;; (add-menu-item 
;;   '("Help") "Comand Glossary" 
;;   'mode-menu-glossary t "List Keybindings")
;; (global-set-key 'button3 'mode-menu)
;; (global-set-key '(meta button3) 'mode-menu-recompute)
;; (add-hook 'find-file-hooks 'mode-menu)
;; 
;; Customization variables
;; (setq mode-menu-add-to-menubar 't)
;; (setq mode-menu-add-in-front-of-menubar 't)
;; ;; This doesn't look very nice. Use the "Command Glossary" item in 
;; ;; the "Help" menu instead
;; (setq mode-menu-compute-global-map-menu 't)

;; Introduction:
;; -------------
;; This package adds generic, mode specific popup menus to Lucid GNU
;; Emacs. These menus are calculated using information from the
;; current local keymap.  There are two functions that can be used to
;; compute and popup automatically generated mode specific menus:
;;
;; mode-menu: Compute and pop up a mode menu. The newly created
;; 	menu is stored in a cache, so if the function is called the
;; 	next time, no recomputation is necessary.
;;
;; mode-menu-recompute: Recompute and pop up a mode menu. If
;; 	there is an already calculated menu stored in the cache, it is
;; 	overridden.  This is useful to recreate a mode menu after
;; 	changes in the local map.
;;

;; Customization:
;; ---------------
;; Both functions are interactive and should be bound to buttons.  You
;; can specify the actual binding of them with the following two
;; variables:
;;
;;     Variable    		Function 		Default Binding
;; -----------------------------------------------------------------   
;; mode-menu-button		mode-menu		button3
;; mode-menu-recompute-button   mode-menu-recompute	meta button3
;;
;; The mode-menu function is bound in the global map, by default to
;; button3 .  Mode specific menus that are delivered with a package
;; usually are also on button3 of the corresponding local keymap. They
;; will override the generic `mode-menu'.
;;
;; Mode motion also provides a command glossary for the global map.
;; Type 
;;		`M-x mode-menu-glossary' 
;;
;; or click on "Command Glossary" in the "Help" menu. This will pop up
;; a buffer named "*Command Glossary*", which contains a kind of
;; permuted index for all key bounded commands in the global map.
;; Clicking with any mouse button on an item in this buffer brings up
;; a menu with all global commands that contain the item as substring.
;;
;;
;; If the user option `mode-menu-add-to-menubar' is non-nil (the
;; default), each newly created menu is automatically added to the the
;; buffer local menubar whenever a new file is opened. Another
;; customization variable, `mode-menu-add-in-front-of-menubar',
;; determines the position where it goes: if the variable is non-nil,
;; the menu is added in head position, otherwise it is inserted before
;; the "Help" menu.
;;
;; Some modes dont have a local map. In this case, the user option
;; `mode-menu-compute-global-map-menu' determines whether the global
;; map should be used to compute the menu. This map is HUGE and the
;; computed menu is very unwieldy, so the variable's default is `nil'.
;;
;; 
;; Advanced features:
;; ------------------
;; The automatic computation of menus yields good results for keymaps
;; of small and middle size, but those of big modes (such as TeX,
;; DIRED, GNUS, VM etc) produce large and unwieldy menus. In this
;; case, the only solution is re-writing a menu by hand. Mode-menu,
;; however, helps you to do this: The command
;; 
;; 		M-x mode-menu-elisp-code
;; 
;; will prompt for a valid keymap and insert, in a new buffer, the
;; complete Emacs Lisp definition of the generic menu, together with
;; the activating mouse command and its local binding in the
;; corresponding keymap.  You then have to edit the definition and
;; make it available when the mode is autoloaded. An example of
;; a mode-hook installation is also created (the name of the mode-hook
;; is guessed. You have to look yourself if it is correct or not).
;;
;; An example:
;;
;; Typing `M-x mode-menu-elisp-code c-mode-map RET' creates the
;; following buffer: (without the very first comment column)
;
;--------------------------- c-mode-menu.el ---------------------------
;;; -*- Mode: Emacs-Lisp -*-
;;;
;;; Automatically generated mode menu for `c-mode-map'.
;;;
;
;(defvar c-mode-menu
;  '("C"
;    ["Backward Delete Char Untabify" backward-delete-char-untabify t]
;    ["C Fill Paragraph" c-fill-paragraph t]
;    ["C Indent Command" c-indent-command t]
;    ["C Insert Braces" c-insert-braces t]
;    ["C Mode Menu" c-mode-menu t]
;    ["Electric C Brace" electric-c-brace t]
;    ["Electric C Semi" electric-c-semi t]
;    ["Electric C Sharp Sign" electric-c-sharp-sign t]
;    ["Electric C Terminator" electric-c-terminator t]
;    ["Indent C Exp" indent-c-exp t]
;    ["Mark C Function" mark-c-function t]
;    ))
;
;(defun c-mode-menu (e)
;  (interactive "@e")
;  (setq zmacs-region-stays 't)
;  (popup-menu c-mode-menu))
;
;(define-key c-mode-map 'button3 'c-mode-menu)
;
;
;;; Put this in your .emacs (for personal installation)
;;; or in default.el (for site installation):
;
;(add-hook 'c-mode-hook
;  (function
;   (lambda ()
;     (and (not (boundp 'c-mode-menu))
;          (load-library "c-mode-menu"))
;     (require 'mode-menu)
;     ;; add menu before the "Help" menu
;     (mode-menu-add-to-menubar c-mode-menu)
;     ;; add menu  in front of the menubar
;     ;; (mode-menu-add-to-menubar c-mode-menu 't)
;     )))    
;-------------------------- end c-mode-menu.el --------------------------

;; Now edit the definition of the variable `c-mode-menu' to make it 
;; nicer and handier, e.g.:

;(defvar c-mode-menu
;  '("C"
;    ["Fill Paragraph" c-fill-paragraph t]
;    ["Indent Line" c-indent-command t]
;    ["Indent Expression" indent-c-exp t]
;    ["Mark Function" mark-c-function t]
;    ["Insert Braces" c-insert-braces t]
;    "----"
;    ("Electric Characters"
;     ["Electric C Brace" electric-c-brace t]
;     ["Electric C Semi" electric-c-semi t]
;     ["Electric C Sharp Sign" electric-c-sharp-sign t]
;     ["Electric C Terminator" electric-c-terminator t])
;    ))
;

;; Move the `add-hook' expression from the generated buffer into
;; your .emacs or in default.el. Save the buffer to a file where
;; Emacs can find it, e.g., .../lisp/locallib/c-mode-menu.el, then byte
;; compile it by typing
;;
;;		M-x byte-compile-file
;;
;; Restart Emcs and visit a C file. A new pulldown menu, "C", appears before 
;; the "Help" menu, and a popup menu is available on button3. 


;; TO DO LIST:
;; -----------
;; o optimize the dumb macro-expansions of the cl macros.
;; o Popup a default menu if there isn't a local keymap. 
;; o Remove the package prefix from command name strings.
;; o Merge prefix submenues if the surrounding menu is to small.
;; o Try to cut more equally large menus during splitting. 
;; o Provide a different method to reorganize to large submenus.
;;   (the "More..." continuation is very nasty for very big tables)
;; o Recognize unnamed functions and keyboard macros in keymaps 
;;   (is this really important??).

(require 'lmenu)
(require 'cl)
(provide 'mode-menu)


;;; User options

(defvar mode-menu-button [mouse-3]
  "Key to bind the `mode-menu' function to.  
If nil, doesn't bind it to any key. This is useful to get the mode
menu just in the menu bar, but not on a key.")

(defvar mode-menu-recompute-button [M-mouse-3]
  "Key to bind the `mode-menu-recompute' function to.  
If nil, doesn't bind it to any key.")

(defvar mode-menu-add-to-menubar 't
  "*If this variable is non-nil (the default), newly created mode menus will
also be added to the menubar.")

(defvar mode-menu-add-in-front-of-menubar nil
  "*If this variable is non-nil, put the newly created menus in front
position of the buffer local menubar, otherwise in end position.")

(defvar mode-menu-min-items-per-submenu 12
  "*The minimal number of entries that must be in a prefix-keymap to be 
put in a own submenu. Smaller keymaps are merged into the parent menu.")

(defvar mode-menu-max-size 25
  "*Maximal number of items allowed in one button menu.
If A keymap is longer, a continuation subtable is created at the end.")

(defvar mode-menu-compute-global-map-menu nil
  "*If this variable is non-nil, a menu is computed for the current
global map if there is no current local map.")


;; Internal variables
(defvar  mode-menu-dont-show-in-menu 
  '(self-insert-command
    picture-self-insert
    digit-argument
    negative-argument
    undefined
    sendmail-self-insert-command)
  "Functions that are not listed in the menu, even if there is 
a keymap entry for.")

(defvar mode-menu-alist nil
  "List with entries of the form \(<major-mode> . <generic mode menu>\)")

(defvar mode-menu-added-to-menubar nil
  "Buffer local variable that is `t' if the mode menu has been added
to the buffer local menubar.")

(make-variable-buffer-local 'mode-menu-added-to-menubar)


;; User interface

(if mode-menu-button 
    (global-set-key mode-menu-button 'mode-menu))

(if mode-menu-recompute-button
    (global-set-key mode-menu-recompute-button 'mode-menu-recompute))

(if mode-menu-add-to-menubar
    (add-hook 'find-file-hooks 'mode-menu))


(defun mode-menu-recompute (event)
  (interactive "@e")
  "Same as `mode-menu', but forces recomputation of the menu. 
This is useful for updating the menu after some modifications in the
keymap."

  ;; Remove an already existing entry.  This leads to a recomputation
  ;; when calling mode-menu
  (setq mode-menu-alist
	(delq (assq major-mode mode-menu-alist)
	      mode-menu-alist))
  (mode-menu event))


(defun mode-menu (&optional event)

  "Popup the generic mode menu if called with an event argument (e.g.
interactively from a button. If such a menu doesn't exist yet, compute
it from the current kymap.  If the user option
`mode-menu-add-to-menubar' is non-nil, add the menu to the menubar,
too.

The function can also be called without argument \(or with `nil'\).
In this case, no menu is poped up, but all the other computation
\(menu calculation, placing it in the menubar\) is done however.

This makes it possible to call this function from the
`find-file-hooks'."

  (interactive "@e")

  (catch 'exit 
    (let* ((entry (assq major-mode mode-menu-alist))
	   keymap menu)

      ;; look for a keymap to compute a menu from
      (or entry 
	  (setq keymap 
		(or (current-local-map) 
		    (and mode-menu-compute-global-map-menu
			 (current-global-map))
		    (if event
			(error "No current local %smap." 
			     (if mode-menu-compute-global-map-menu 
				 "or global " ""))
		      (throw 'exit nil)))))
      (if entry  
	  (setq menu (cdr entry))
      
	(message "Creating generic mode menu for %s" major-mode)
	(setq mode-menu-alist
	      (cons 
	       (cons major-mode
		     (setq menu
			   (mode-menu-from-keymap
			    keymap
			    (mode-menu-title major-mode))))
	       mode-menu-alist)))

      ;; Add the popup menu as pull-down menu to the menubar, if
      ;; not already there
      (mode-menu-add-to-menubar
	    menu mode-menu-add-in-front-of-menubar)

;      (and mode-menu-add-to-menubar
;           (not mode-menu-added-to-menubar)
;           (mode-menu-add-to-menubar
;            menu mode-menu-add-in-front-of-menubar)
;           ;; notice that the mode menu has been added
;           (setq mode-menu-added-to-menubar 't))

      (if event 
	  (progn 
	    ;; keep zmacs region active
	    (setq zmacs-region-stays t)
	    (popup-menu menu)
	    (message ""))))))


(defun mode-menu-add-to-menubar (menu &optional front-position title)
  "Add MENU to the buffer local menubar. MENU must have the form
\(\"MenuName\" <menu item> ... \).  If there isn't yet a buffer local
menubar, create one by copying the global current menubar. 

A new menu is only added if there isn't already one with the same name.
The menu is added in front of the current menubar if the optional
argument FRONT-POSITION is non-nil, otherwise it appeares before the
\"Help\" menu. If third argument TITLE (a string) is present, this
will be the menus title in the menubar."

  (or title (setq title (car menu)))

  ;; make shure that there is a buffer local menubar
  (if (eq current-menubar (default-value 'current-menubar))
      (set-buffer-menubar (default-value 'current-menubar)))

  (or (member title (mapcar 'car current-menubar))
      (if front-position
	  ;; Put the mode-menu in front position
	  (setq current-menubar (cons menu current-menubar))
	;; Otherwise, put the new menu before the "Help" menu
	;; (there is a cached `nil' entry that marks this place.)
	(add-menu nil title (cdr menu)))))




(defun mode-menu-elisp-code (mode-map)
  "Ask for a keymap or a variable with a keymap as value,
transform it into a popup menu and insert it properly indented
into the current buffer at point."
  (interactive
   (list (intern-soft
	  (completing-read
	   "Mode map: "
	   obarray
	   '(lambda (x)
	      (or (keymapp x)
		  (and (boundp x)
		       (keymapp (symbol-value x)))))
	   t nil))))

  (let* ((mode-map-name (symbol-name mode-map))
	 (package-name
	  (if (string-match "-mode-map$" mode-map-name)
	      (substring mode-map-name 0 (match-beginning 0))
	    (read-from-minibuffer "Package name: " mode-map-name)))
	 (mode-name-string (concat package-name "-mode"))
	 (menu-var (concat mode-name-string "-menu"))
	 (buffer (get-buffer-create (concat menu-var ".el")))
	 )

    (pop-to-buffer buffer)
    (erase-buffer)
    (emacs-lisp-mode)
    (insert ";; -*- Mode: Emacs-Lisp -*-\n")
    (insert
     (format
      ";;\n;; Automatically generated mode menu for `%s'.\n;;\n"
      mode-map))
    (insert (format "\n\(defvar %s\n  '" menu-var))
    (mode-menu-pp
     (mode-menu-from-keymap mode-map (capitalize package-name)))
    (insert ")")

    (insert (format "\n
\(defun %s \(e\)
  \(interactive \"@e\"\)
  \(setq zmacs-region-stays 't\)
  \(popup-menu %s\)\)
" menu-var menu-var))

    (insert (format "\n\(define-key %s [mouse-3] '%s\)"
		    mode-map-name menu-var))

    (insert "\n\n
\;\; Put this in your .emacs (for personal installation)
\;\; or in default.el (for site installation):")

    (insert (format "\n
\(add-hook '%s-hook
  \(function
   \(lambda \(\)
     \(and \(not \(boundp '%s\)\)
	  \(load-library \"%s\"\)\)
     \(require 'mode-menu\)
     \;\; add menu before the \"Help\" menu
     \(mode-menu-add-to-menubar %s\)
     \;\; add menu in front of the menubar
     \;\; \(mode-menu-add-to-menubar %s 't\)
     \)\)\)    
" mode-name-string menu-var menu-var menu-var menu-var))))



;; Internal functions

(defvar mode-menu-title-alist
  '((mail-mode . "SendMail")
    (emacs-lisp-mode . "Elisp")
    (lisp-interaction-mode . "Elisp")
    )
  "Alist associating mode names with menu titles.  This is useful for
avoiding clumsy menu titles for complicated major mode names.  It also
allows mode-menu to have the same menu titles as built-in menus, which
avoids having different menus for the same mode in one menubar.")

(defun mode-menu-title (symbol)
  "Make a (hopefully) short string from SYMBOL (the mjor mode, usually)."
  (or (cdr (assoc symbol mode-menu-title-alist))
      (let* ((name (capitalize (symbol-name symbol)))
	     (case-fold-search t))
	;; remove "-mode" suffix
	(if (string-match "-mode$" name)
	    (setq name
		  (substring name 0 (match-beginning 0))))
	(apply 'concat 
	       (string-split "-" name)))))

;; This is stohlen from the elib library (not yet in the standard
;; distribution, alas)
(or (fboundp 'string-split)
    (defun string-split (pattern string &optional limit)
      "Splitting on regexp PATTERN, turn string STRING into a list of substrings.
Optional third arg LIMIT (>= 1) is a limit to the length of the
resulting list."

      (let ((data (match-data)))
	(unwind-protect
	    (let* ((start (string-match pattern string))
		   (result (list (substring string 0 start)))
		   (count 1)
		   (end (if start (match-end 0))))
	      (if end			; else nothing left
		  (while (and (or (not (integerp limit))
				  (< count limit))
			      (string-match pattern string end))
		    (setq start (match-beginning 0)
			  count (1+ count)
			  result (cons (substring string end start) result)
			  end (match-end 0)
			  start end)))
	      (if (and (or (not (integerp limit))
			   (< count limit))
		       end)		; else nothing left
		  (setq result
			(cons (substring string end) result)))
	      (nreverse result))
	  (store-match-data data)))))

;;(mode-menu-title 'dired-mode)
;;(mode-menu-title 'C++-mode)
;;(mode-menu-title major-mode)

(defun mode-menu-pp (menu &optional buffer)
  "Pretty print MENU in BUFFER \(default: current buffer\)."

  (or buffer (setq buffer (current-buffer)))
  (princ "(" buffer)
  (let (entry (rest menu))
    (while rest 
      (setq entry (car rest)
	    rest (cdr rest))
      (if (consp entry)
	  (mode-menu-pp entry buffer)
	(prin1 entry buffer)
	(newline-and-indent))))
      
;;;  (dolist (entry menu)
;;;    (if (consp entry)
;;;        (mode-menu-pp entry buffer)
;;;      (prin1 entry buffer)
;;;      (newline-and-indent)))
  (princ ")" buffer))


;; non-local variable
(defvar mode-menu-visited-functions)

(defun mode-menu-from-keymap (mode-map title)
  "Create a popup menu with the command entries of MODE-MAP and title
TITLE.  If a sub-keymap containes more than
`mode-menu-min-items-per-submenu' entries, put them into a proper
submenu. If the main menu containes more than `mode-menu-max-size' items, 
put the rest in one (ore more) continuing submenus."

  ;; non-local variable, used in mode-menu-keymap-to-menu
  (let ((mode-menu-visited-functions))
    (cons title
	  (mode-menu-cut-long-table
	   (mode-menu-reorganize-table
	    (mode-menu-keymap-to-menu mode-map))))))


(defsubst item-label (item)
  (aref item 0))

;;(defsubst item-entry (item)
;;  (aref item 1))

(defun mode-menu-reorganize-table (table)
  "Reorganizes TABLE in the following way: All submenus with 
fewer than  `mode-menu-min-items-per-submenu' entries are 
merged into the surrounding table."

  (let (entry (rest table))

;;;    (do* ((rest table (rest rest))
;;;          (entry (first rest) (first rest)))
;;;        ((null rest))
;;;      (when (consp  entry);; table
;;;        (setf (rest entry) (mode-menu-reorganize-table  (rest entry)))
;;;
;;;        ;; reorganize sub-table recursively
;;;        (if (< (length (rest entry)) mode-menu-min-items-per-submenu)
;;;            (let ((rest-rest (rest rest))
;;;                  (submenu (rest entry)))
;;;              (if (= 1 (length submenu))
;;;                  (setf (first rest) (first submenu))
;;;                (setf (first rest) (first submenu))
;;;                (setf (rest rest) (rest submenu))
;;;                (setf (rest (last submenu)) rest-rest))
;;;              ))))

    ;; macroexpansion of the above (+ hand optimization)
    (let* ((rest table)
	   (entry (car rest)))
      (while (not (null rest))
	(if (not (consp entry))
	    nil
	  (setcdr entry (mode-menu-reorganize-table (cdr entry)))
	  (if (< (length (cdr entry))
	       mode-menu-min-items-per-submenu)
	      (let ((rest-rest (cdr rest))
		    (submenu (cdr entry)))
		(if (= 1 (length submenu))
		    (mode-menu-setnth 0 rest (car submenu))
		  (mode-menu-setnth 0 rest (car submenu))
		  (setcdr rest (cdr submenu))
		  (setcdr (mode-menu-last submenu) rest-rest)))))
	(setq rest (cdr rest) entry (car rest))))

    (sort table 'mode-menu-entry-lesser)))


(defun mode-menu-cut-long-table (table)
  "Shortens a menu with more then `mode-menu-max-size' items
by creating one or more \"More... \" submenus."
  (let ((count 1)
	(rest table))
    
    (while (and rest (< count mode-menu-max-size))
      (if (consp (car rest))
	  (mode-menu-cut-long-table (car rest)))
      (setq count (1+ count)
	    rest (cdr rest)))
    (if rest
	(let ((continue (cons (car rest) (cdr rest))))
	  (rplacd rest nil)
	  (rplaca rest
		  (cons "More..."
			(mode-menu-cut-long-table continue))))))
  table)

(defun mode-menu-entry-lesser (e1 e2)
  "Predicate that compares two menu entries E1 and E2 for beeing lesser: 
If E1 and E2 are both flat entries or subtables, apply `string-lessp' 
to the  entry labls. If one of them is a flat entry and the other 
a subtable, the  flat entry is smaller."

  (if (consp e1) 
      (if (consp e2) ; e1 & e2 subtables
	  (string-lessp (car e1) (car e2)) ;compare their titles
	'nil) 
    (if (consp e2) 
	't ; e1 not sub but e2
  (string-lessp (item-label e1) (item-label e2)))))

;; (mode-menu-show-keymap (current-local-map) "Current local map")


;; basic routine that transforms a keymap into a popup menu structure. 
(defun mode-menu-keymap-to-menu (keymap &optional prefix-string)
  (let (table)
    (delq
     'nil
     (cond ((keymapp keymap)
	    ;; transform the keymap itself
	    (cl-map-keymap
	     '(lambda (key-description binding)
		(setq table 
		      (cons (mode-menu-make-entry
			     key-description binding prefix-string)
			    table)))
	     keymap)
	    ;; don't forget the keymaps parent! (if exists)
	    ;(if (and (keymap-parent  keymap)
;		     (not (eq (keymap-parent  keymap) global-map)))
;		(cl-map-keymap
;		 '(lambda (key-description binding)
;		    (setq  table
;			   (cons (mode-menu-make-entry
;				  key-description binding prefix-string)
;				 table)))
;		 (keymap-parent  keymap)))
	    table)

	   ((and (not (null keymap))(symbolp keymap)(boundp keymap))
	    (mode-menu-keymap-to-menu (symbol-value keymap)))

	   (t
	    (error "Not a keymap: %s" keymap))))))

;(let ((mode-menu-visited-functions nil))
;  (mode-menu-keymap-to-menu  shell-mode-map))


(defun mode-menu-make-entry (index entry prefix-string)
  "Return a list that serves as entry in a menu description table. 
Arguments are: 
 INDEX		- the character position in the surrounding keymap
 ENTRY		- the keymap entry at that place
 PREFIX-STRING	- string indicating the prefix characters of that entry"

  ;; uses non-local variable mode-menu-visited-functions
  (cond
   ((null entry) nil)
   
   ((symbolp entry)
    (cond

     ;; don't put undesired commands in the menu
     ((memq entry mode-menu-dont-show-in-menu) nil)
     ;; same for commands already fund so far
     ((memq entry mode-menu-visited-functions) nil)

     ((fboundp entry)

      (if (keymapp (symbol-function entry))
	  ;; keymap entry 
	  (let ((intermediate-table
		 (mode-menu-keymap-to-menu
		  (symbol-function entry)
		  (concat prefix-string
			  (single-key-description index) " "))))
	    (if intermediate-table	; allows only entries
		(cons			; for which there is a defined table.
		 (concat
		  prefix-string (single-key-description index) " Prefix")
		 intermediate-table)))

	;; command entry
	(setq mode-menu-visited-functions
	      (cons entry mode-menu-visited-functions))
	(vector (mode-menu-make-command-name-string (symbol-name entry))
		entry
		't)))

     ((boundp entry);; prefix keymap
      (error "keymap entry is a variable")
      (let ((intermediate-table
	     (mode-menu-keymap-to-menu
	      (symbol-value entry)
	      (concat (single-key-description index))))
	    )
	(if intermediate-table		; allows only entries
	    (list
	     (concat 
	      (single-key-description index) " Prefix Keymap")
	     intermediate-table))))

     (t
      (vector (concat "Bogus entry: " (symbol-name entry)) entry 't))))

   ((stringp entry);; Keybord Macro
    nil)
   ;;    (list "Keybord Macro"
   ;;          (concat prefix-string (single-key-description index))
   ;;          entry))


   ((keymapp entry)
    (let ((intermediate-table
	   (mode-menu-keymap-to-menu
	    entry 
	    (concat prefix-string 
		    (single-key-description index) " "))))

      (if intermediate-table		; allows only entries
	  (cons				; for which there is a defined table.
	   (concat
	    prefix-string (single-key-description index) " Prefix")
	   intermediate-table))))

   ((and (listp entry) (eq 'lambda (car entry)));; (lambda (...) ...)
    nil)
   ;;    ;; (functionp entry)
   ;;    (list "Unnamed Function"
   ;;          (concat prefix-string (single-key-description index))
   ;;          entry))

   ((vectorp entry) ;; what does this mean???
    nil)
	
   (t (error "unknown keymap entry: %s" entry))))


(defun mode-menu-make-command-name-string (string)
  ;; in order to not change the real symbol names 
  (setq string (copy-sequence string))

;;;  (dotimes (i (length string))
;;;    (if (memq  (aref string i) '(?- ?: ?-))
;;;        (setf (aref string i) ? )))
  

  ;; macroexpansion of the above (not yet optimized)
  (let* ((T$$_7319 (length string)))
    (let* ((i 0))
      (while (not (>= i T$$_7319))
	(if (memq (aref string i) '(45 58 45))
	    (aset string i 32))
	(setq i (+ i 1)))
      nil))

  (capitalize string))


;; Stuff for debugging
;
;(defun print-keymap-entry (key entry &optional offset)
;  (or offset (setq offset 0))
;  (if (not (keymapp entry))
;      (insert "\n" (make-string offset ? )
;              (format "Key: %s; Entry: %s" key entry))
;    (insert "\n" (make-string offset ? )
;     (format "Prefix Key: %s:" key))
;    (cl-map-keymap entry 
;                '(lambda (key entry)
;                   (print-keymap-entry key entry (+ 2 offset))))))
;
;(print-keymap-entry "" emacs-lisp-mode-map)


;; cl utils, prefixed with "mode-menu-"
(defun mode-menu-setnth  (n list newval)
  "Set (nth N LIST) to NEWVAL.  Returns NEWVAL."
  (rplaca (nthcdr n list) newval))

(defun mode-menu-last (x)
  "Returns the last link in the list LIST."
  (if (nlistp x)
      (error "Arg to `last' must be a list"))
  (let ((current-cons x)
	(next-cons (cdr x)))
    (while (not (mode-menu-endp next-cons))
      (let ((\03 (cdr current-cons)) 
	    (\02 (cdr next-cons))) 
	(setq current-cons \03 next-cons \02) nil))
    current-cons))

(defun mode-menu-endp (x)
  "t if X is nil, nil if X is a cons; error otherwise."
  (if (listp x)
      (null x)
    (error "mode-menu-endp received a non-cons, non-null argument `%s'"
	   (prin1-to-string x))))


;; from the elib `strings'
(defun mode-menu-string-split (pattern string &optional limit)
  "Splitting on regexp PATTERN, turn string STRING into a list of substrings.
Optional third arg LIMIT (>= 1) is a limit to the length of the
resulting list."

  (let ((data (match-data)))
    (unwind-protect
	(let* ((start (string-match pattern string))
	       (result (list (substring string 0 start)))
	       (count 1)
	       (end (if start (match-end 0))))
	  (if end			; else nothing left
	      (while (and (or (not (integerp limit))
			      (< count limit))
			  (string-match pattern string end))
		(setq start (match-beginning 0)
		      count (1+ count)
		      result (cons (substring string end start) result)
		      end (match-end 0)
		      start end)))
	  (if (and (or (not (integerp limit))
		       (< count limit))
		   end)			; else nothing left
	      (setq result
		    (cons (substring string end) result)))
	  (nreverse result))
      (store-match-data data))))


;; Glossary of all global map commands

(defvar mode-menu-glossary-table nil)

(defun mode-menu-glossary ()
  (interactive)
  (let ((glossary-buffer (get-buffer-create "*Command Glossary*")))
    (switch-to-buffer glossary-buffer)
    (set-buffer glossary-buffer)
    (if (and (boundp 'mode-menu-glossary-table)
	     mode-menu-glossary-table)
	()
      (setq buffer-read-only nil)
      (erase-buffer)
      (setq mode-menu-glossary-table (make-hashtable 211))
      (mapcar 
       '(lambda (entry) 
	  (mapcar 
	   '(lambda (string)
	      (setq string (intern string))
	      ;; hash the command entries 
	      (puthash string
		       (cons entry 
			     (gethash string mode-menu-glossary-table))
		       mode-menu-glossary-table))
	   ;; split the command names 
	   (mode-menu-string-split " " (aref entry 0))))
       ;; compute a flat table with all commands of the global map
       (prog2 
	   (message "Computing table from the global-map ...")
	   (mode-menu-flatten-table
	    (let (mode-menu-visited-functions)
	      (mode-menu-keymap-to-menu global-map)))
	 (message "Dispatching table entries ...")))
      (message "Sorting glossary entries ...")
      (maphash '(lambda (key value)
		  (puthash 
		   key 
		   (cons 
		    ""
		    (cons 
		     (format "Commands containing \"%s\":" key)
		     (cons 
		      "-----" 
		      (sort 
		       value
		       '(lambda (e1 e2)
			  (string< (aref e1 0)(aref e2 0)))))))
		   mode-menu-glossary-table))
	       mode-menu-glossary-table)
      (let ((standard-output  
	     (get-buffer-create "*Command Glossary*")
	     ;; glossary-buffer
	     ))
	(display-completion-list
	 (let (list)
	   (maphash  
	    '(lambda (key value)
	       (setq list (cons (symbol-name key) list)))
	    mode-menu-glossary-table)
	   (sort list 'string<)))
	(local-set-key [mouse-3] 'glossary-menu)
	(local-set-key [mouse-2] 'glossary-menu)
	(local-set-key [mouse-1] 'glossary-menu)
	(goto-char (point-min))
	;; remove header line inserted by the display-completion-list
	;; command
	(kill-line)
	(delete-char 1)
	(setq buffer-read-only t)
	(if (featurep 'mode-motion+) 
	    (set-buffer-motion-handler 
	     (current-buffer) 'highlight-thing))
	))
    (goto-char (point-min))))


;; (or (vectorp (car (find-menu-item default-menubar 
;;				  '("Help" "Comand Glossary"))))
;;    (add-menu-item 
;;     '("Help") "Comand Glossary" 
;;     'mode-menu-glossary t "List Keybindings"))


(defun glossary-menu (event)
  (interactive "e")
  (mouse-set-point event)
  (let* ((command-characters "a-zA-Z0-9")
	 (string 
	  (buffer-substring 
	   (progn 
	     (skip-chars-backward command-characters)
	     (point))
	   (progn 
	     (skip-chars-forward command-characters)
	     (point)))))
    (if (string= string "")
	(error "Click on a string.")
      (popup-menu
       (or 
	   (gethash (intern string) mode-menu-glossary-table)
	   (error "No entry in glossary table: %s"  string))))))

(defun mode-menu-flatten-table (table)
  (let* ((rest table)
	 (entry (car rest)))
    (while (not (null rest))
      (if (not (consp entry))
	  nil
	(setcdr entry (mode-menu-flatten-table (cdr entry)))
	(let ((rest-rest (cdr rest))
	      (submenu (cdr entry)))
	  (if (= 1 (length submenu))
	      (mode-menu-setnth 0 rest (car submenu))
	    (mode-menu-setnth 0 rest (car submenu))
	    (setcdr rest (cdr submenu))
	    (setcdr (mode-menu-last submenu) rest-rest))))
      (setq rest (cdr rest) entry (car rest))))
  table)
	    
;(mode-menu-flatten-table
; (let (mode-menu-visited-functions)
;   (mode-menu-keymap-to-menu global-map))))

;; the inevitable load hook
(run-hooks 'mode-menu-load-hook)
;; end mode-menu.el
--------------------------------- snip here ---------------------------