home *** CD-ROM | disk | FTP | other *** search
/ InfoMagic Source Code 1993 July / THE_SOURCE_CODE_CD_ROM.iso / languages / elisp / epoch / generic-bind.el < prev    next >
Encoding:
Text File  |  1991-03-30  |  8.3 KB  |  201 lines
  1. ; Date: Tue, 18 Sep 90 16:51:27 EDT
  2. ; From: Ken Laprade <laprade@trantor.harris-atd.com>
  3. ; Subject: Generic function key binding
  4. ; 
  5. ; Here is a function I came up with to generically setup function key
  6. ; definitions.  There is a different definition of the function for epoch, X,
  7. ; or emacstool.  The same invocations of the function can be used in all
  8. ; cases.  Thus these bindings work for me no matter which emacs I run:
  9. ; 
  10. ;    (define-function-key "F1" 'describe-function)
  11. ;    (define-function-key "M-F1" 'describe-variable)
  12. ;    (define-function-key "R5" "\C-V")
  13. ;    (define-function-key "M-R5" 'scroll-other-window)
  14. ;    (define-function-key "R6" "\M->")
  15. ;    (define-function-key "M-R6" 'end-of-buffer-other-window)
  16. ;    (define-function-key "S-R5" 'scroll-other-screen-up)
  17. ;    (define-function-key "S-R6" 'end-of-buffer-other-screen)
  18. ;
  19. ; These functions are written with a Sun3 keyboard in mind, but they could be
  20. ; easily adapted to anything.
  21. ;
  22. ; This is the epoch version:
  23. ;
  24. ; -- 
  25. ; Ken Laprade            INTERNET: laprade@trantor.harris-atd.com
  26. ; Harris Corporation         Usenet:  ...!uunet!x102a!trantor!laprade
  27. ; PO Box 37, MS 3A/1912        Voice: (407)727-4433
  28. ; Melbourne, FL 32902        FAX: (407)729-2537
  29. ;
  30. ; ----------
  31.  
  32. ;;; Support for generic function key binding (by Ken Laprade):
  33. ;;;
  34. (setq with-shift (epoch::mod-to-shiftmask 0))
  35. (setq with-control (epoch::mod-to-shiftmask 2))
  36. (setq with-meta (epoch::mod-to-shiftmask 3))
  37.  
  38. (defvar function-key-prefix-string "\C-X*"
  39.   "Prefix for function key definitions created by define-function-key.")
  40.  
  41. (defun define-function-key (key def &optional epoch-def)
  42.   "Globally define a generic function key for epoch.  KEY is a string naming
  43. the key (as known to X) with optional `M', `S', or `C' prefixes specifying
  44. meta, shift and control qualifiers.  Prefixes are separated from the key
  45. name by a hyphen.  DEF is the key definition.  It may be any valid
  46. ddefinition for define-key.  If it is a string, it will be directly bound
  47. to the key using rebind-key.  If the optional EPOCH-DEF is supplied, it
  48. is used rather than def."
  49.   (interactive "sFunction key name: \nxDefinition: ")
  50.   (if epoch-def (setq def epoch-def))
  51.   (let* ((i (string-match "-" key))
  52.      (keyname (let ((name (substring key (if i (1+ i) 0))))
  53.             (cond ((string-match "R8" name) "Up")
  54.               ((string-match "R10" name) "Left")
  55.               ((string-match "R12" name) "Right")
  56.               ((string-match "R14" name) "Down")
  57.               (t name))))
  58.      (meta (string-match "M.*-" key))
  59.      (shift (string-match "S.*-" key))
  60.      (control (string-match "C.*-" key))
  61.      (quals (logior (if meta with-meta 0)
  62.             (if shift with-shift 0)
  63.             (if control with-control 0))))
  64.     (if (stringp def)
  65.     (rebind-key keyname quals def)
  66.       ;; Make an intermediate binding for the definition.
  67.       (let* ((keytype (cond ((string-match "L\\([1-9]\\|10\\)$" key) "L")
  68.                 ((string-match "F\\([1-9]\\)$" key) "F")
  69.                 ((string-match "R\\([1-9]\\|1[0-5]\\)$" key) "R")
  70.                 (t keyname)))
  71.          (keynum (and (match-beginning 1)
  72.               (string-to-int (substring key (match-beginning 1) (match-end 1)))))
  73.          (binding (concat function-key-prefix-string
  74.                   (if meta "M") (if shift "S") (if control "C")
  75.                   keytype
  76.                   (if keynum (format "%02d" keynum)))))
  77.     (rebind-key keyname quals binding)
  78.     (global-set-key binding def)))))
  79. ----------
  80. This is the version for X emacs:
  81. ----------
  82. ;;; Support for generic function key binding (by Ken Laprade):
  83. ;;;
  84. (defun define-function-key (key def &optional ignored)
  85.   "Globally define a generic function key for Sun3 keyboards.  KEY is a
  86. string naming the key (L1-L10, F1-F9, R1-15) with optional `M', `S', or `C'
  87. prefixes specifying meta, control, and shift qualifiers.  Prefixes are
  88. separated from the key name by a hyphen.  Raw keys (as from the normal X
  89. version) do not provide the shift or control prefixes, but the emacstool
  90. version does.  Both maps are setup by this function.  DEF is the key
  91. definition.  It may be any valid definition for define-key."
  92.   (interactive "sFunction key name: \nxDefinition: ")
  93.   (let* ((i (string-match "-" key))
  94.      (keyname (let ((name (substring key (if i (1+ i) 0))))
  95.             (cond ((string-match "Up" name) "R8")
  96.               ((string-match "Left" name) "R10")
  97.               ((string-match "Right" name) "R12")
  98.               ((string-match "Down" name) "R14")
  99.               (t name))))
  100.      (meta (string-match "M.*-" key))
  101.      (shift (string-match "S.*-" key))
  102.      (control (string-match "C.*-" key))
  103.      (keybase (cond ((string-match "L\\([1-9]\\|10\\)$" keyname) 191)
  104.               ((string-match "F\\([1-9]\\)$" keyname) 223)
  105.               ((string-match "R\\([1-9]\\|1[0-5]\\)$" keyname) 207)
  106.               (t 0)))    ; Unknown key.
  107.      (keynum (if (match-beginning 1)
  108.               (string-to-int (substring keyname (match-beginning 1) (match-end 1)))
  109.            0)))
  110.     ;; The raw key version:
  111.     (or shift control (not sun-esc-bracket)
  112.     (global-set-key (format "%s[%03dz"
  113.                 (if meta "\M-\e" "\e")
  114.                 (+ keybase keynum))
  115.             def))))
  116.  
  117. (defvar sun-raw-map (make-sparse-keymap) "*Keymap for ESC-[ encoded keyboard")
  118. (defvar sun-meta-raw-map (make-sparse-keymap) "*Keymap for Meta-ESC-[ encoded keyboard")
  119.  
  120. (defvar sun-esc-bracket t
  121.   "*If non-nil, rebind ESC [ as prefix for Sun function keys.")
  122.  
  123. ;;; Hook in the function key maps:
  124. (if sun-esc-bracket
  125.     (progn
  126.       (define-key esc-map "[" sun-raw-map)        ; Install sun-raw-map
  127.       (global-set-key "\M-\e[" sun-meta-raw-map)    ; Install sun-meta-raw-map
  128.       (define-key esc-map "[A" 'previous-line )        ; R8
  129.       (define-key esc-map "[B" 'next-line)        ; R14
  130.       (define-key esc-map "[C" 'forward-char)        ; R12
  131.       (define-key esc-map "[D" 'backward-char)        ; R10
  132.       (define-key esc-map "[[" 'backward-paragraph)    ; the original esc-[
  133.       ))
  134. ----------
  135. And this is what I threw into our local copy of term/sun.el:
  136. ----------
  137. ;;; Support for generic function key binding (by Ken Laprade):
  138. ;;;
  139. (defun define-function-key (key def &optional ignored)
  140.   "Globally define a generic function key for Sun3 keyboards.  KEY is a
  141. string naming the key (L1-L10, F1-F9, R1-15) with optional `M', `S', or `C'
  142. prefixes specifying meta, control, and shift qualifiers.  Prefixes are
  143. separated from the key name by a hyphen.  Raw keys (as from the normal X
  144. version) do not provide the shift or control prefixes, but the emacstool
  145. version does.  Both maps are setup by this function.  DEF is the key
  146. definition.  It may be any valid definition for define-key."
  147.   (interactive "sFunction key name: \nxDefinition: ")
  148.   (let* ((i (string-match "-" key))
  149.      (keyname (let ((name (substring key (if i (1+ i) 0))))
  150.             (cond ((string-match "Up" name) "R8")
  151.               ((string-match "Left" name) "R10")
  152.               ((string-match "Right" name) "R12")
  153.               ((string-match "Down" name) "R14")
  154.               (t name))))
  155.      (meta (string-match "M.*-" key))
  156.      (shift (string-match "S.*-" key))
  157.      (control (string-match "C.*-" key))
  158.      (keybase (cond ((string-match "L\\([1-9]\\|10\\)$" keyname) 191)
  159.               ((string-match "F\\([1-9]\\)$" keyname) 223)
  160.               ((string-match "R\\([1-9]\\|1[0-5]\\)$" keyname) 207)
  161.               (t 0)))    ; Unknown key.
  162.      (keynum (if (match-beginning 1)
  163.               (string-to-int (substring keyname (match-beginning 1) (match-end 1)))
  164.            0)))
  165.     ;; The raw key version:
  166.     (or shift control (not sun-esc-bracket)
  167.     (global-set-key (format "%s[%03dz"
  168.                 (if meta "\M-\e" "\e")
  169.                 (+ keybase keynum))
  170.             def))
  171.     ;; The emacstool version:
  172.     (global-set-key (format "\C-X*%c%c"
  173.                 (+ keynum ?`)
  174.                 (+ (cond ((= keybase 191) ?l)
  175.                      ((= keybase 223) ?t)
  176.                      ((= keybase 207) ?r)
  177.                      ((= keybase 0) ??))
  178.                    (if control -64 0)
  179.                    (if shift -32 0)
  180.                    (if meta 128 0)))
  181.             def)))
  182.  
  183. (defvar sup-map (make-keymap) "Default keymap for SUP (meta-meta) commands.")
  184. (defvar sun-raw-map (make-sparse-keymap) "*Keymap for ESC-[ encoded keyboard")
  185. (defvar sun-meta-raw-map (make-sparse-keymap) "*Keymap for Meta-ESC-[ encoded keyboard")
  186. (defvar suntool-map (make-sparse-keymap) "*Keymap for Emacstool bindings.")
  187.  
  188. ;;; Hook in the function key maps:
  189. (define-key ctl-x-map "*" suntool-map)
  190. (if sun-esc-bracket
  191.     (progn
  192.       (define-key esc-map "[" sun-raw-map)        ; Install sun-raw-map
  193.       (define-key esc-map "\e" sup-map)            ; Install sup-map
  194.       (define-key sup-map "\e" sun-meta-raw-map)    ; Install sun-meta-raw-map
  195.       (define-key esc-map "[A" 'previous-line )        ; R8
  196.       (define-key esc-map "[B" 'next-line)        ; R14
  197.       (define-key esc-map "[C" 'forward-char)        ; R12
  198.       (define-key esc-map "[D" 'backward-char)        ; R10
  199.       (define-key esc-map "[[" 'backward-paragraph)    ; the original esc-[
  200.       ))
  201.