| 1 | (in-package "ELISP")
|
|---|
| 2 |
|
|---|
| 3 | (cl:defun mangle-key (key)
|
|---|
| 4 | "Turn a CL-elisp key designator to a PHemlock KEY-EVENT"
|
|---|
| 5 | (typecase key
|
|---|
| 6 | ; (string (with-input-from-string (stream key)
|
|---|
| 7 | ; (let ((*readtable* elisp-internals:*elisp-readtable*))
|
|---|
| 8 | ; (elisp-internals::read-string-char stream :event))))
|
|---|
| 9 | (string (map 'vector #'mangle-key key))
|
|---|
| 10 | ((or vector array)
|
|---|
| 11 | (map 'vector #'mangle-key key))
|
|---|
| 12 | (hemlock-ext:key-event key)
|
|---|
| 13 | ((or integer character)
|
|---|
| 14 | (multiple-value-bind (ismeta ischar) (truncate (if (characterp key)
|
|---|
| 15 | (char-code key)
|
|---|
| 16 | key)
|
|---|
| 17 | 128)
|
|---|
| 18 | (cl:let ((charspec (if (cl:= 1 ismeta) (list :meta))))
|
|---|
| 19 | (when (< ischar 32)
|
|---|
| 20 | (push :control charspec)
|
|---|
| 21 | (setq ischar (1- (+ ischar (char-code #\a)))))
|
|---|
| 22 | (push (code-char ischar) charspec)
|
|---|
| 23 | (elisp-internals::emit-character (reverse charspec) :event)
|
|---|
| 24 | )))))
|
|---|
| 25 |
|
|---|
| 26 | (cl:defun global-set-key (key command)
|
|---|
| 27 | (let ((key (mangle-key key)))
|
|---|
| 28 | (bind-key (string command) key :global)))
|
|---|
| 29 |
|
|---|
| 30 | (cl:defun local-set-key (key command)
|
|---|
| 31 | (let ((key (mangle-key key)))
|
|---|
| 32 | (bind-key (string command) key :mode major-mode)))
|
|---|
| 33 |
|
|---|
| 34 | (cl:defun use-local-map (keymap)
|
|---|
| 35 | (cond ((and (listp keymap)
|
|---|
| 36 | (eq (car keymap) 'keymap))
|
|---|
| 37 | (cl:let ((has-menu-name (stringp (cadr keymap))))
|
|---|
| 38 | (let ((char-table (if has-menu-name
|
|---|
| 39 | (if (vectorp (caddr keymap))
|
|---|
| 40 | (caddr keymap))
|
|---|
| 41 | (if (vectorp (cadr keymap))
|
|---|
| 42 | (cadr keymap))))
|
|---|
| 43 | (the-alist (if has-menu-name
|
|---|
| 44 | (if (vectorp (caddr keymap))
|
|---|
| 45 | (cdddr keymap))
|
|---|
| 46 | (if (vectorp (cadr keymap))
|
|---|
| 47 | (cddr keymap)))))
|
|---|
| 48 | ; iterate through the relevant sections
|
|---|
| 49 | )))
|
|---|
| 50 | ((symbolp keymap)
|
|---|
| 51 | (use-local-map (eval keymap)))))
|
|---|
| 52 |
|
|---|
| 53 | (cl:defun get-buffer-create (buffer-name)
|
|---|
| 54 | (or (getstring buffer-name *buffer-names*)
|
|---|
| 55 | (make-buffer buffer-name)))
|
|---|
| 56 |
|
|---|
| 57 | (cl:defun get-buffer (buffer-name)
|
|---|
| 58 | (getstring buffer-name *buffer-names*))
|
|---|
| 59 |
|
|---|
| 60 | (cl:defun commandp (function-designator)
|
|---|
| 61 | (typecase function-designator
|
|---|
| 62 | (symbol (hemlock-internals:commandp (getstring (string-downcase (string function-designator)) hemlock-internals:*command-names*)))
|
|---|
| 63 | (function nil) ; Bug, but as far as I can tell, we can't portably
|
|---|
| 64 | ; extract the name from the function object
|
|---|
| 65 | (string (hemlock-internals:commandp (getstring (string-downcase function-designator) hemlock-internals:*command-names*)))
|
|---|
| 66 | (t nil)))
|
|---|
| 67 |
|
|---|
| 68 | (cl:defun bolp ()
|
|---|
| 69 | (= 0 (hemlock-internals:mark-charpos (hemlock-internals:current-point))))
|
|---|
| 70 |
|
|---|
| 71 | (cl:defun bobp ()
|
|---|
| 72 | (and (= 0 (hemlock-internals::line-number (hemlock-internals:mark-line (hemlock-internals:current-point))))
|
|---|
| 73 | (bolp)))
|
|---|
| 74 |
|
|---|
| 75 | (cl:defun abort-recursive-edit ()
|
|---|
| 76 | (and (hemlock-internals:in-recursive-edit)
|
|---|
| 77 | (hemlock-internals:exit-recursive-edit)))
|
|---|
