From: tailor Date: Fri, 11 May 2007 18:11:33 +0000 (+0000) Subject: [lice @ more rearranging. define-key modifications to accomodate bindings.lisp. this... X-Git-Url: https://repo.or.cz/w/lice.git/commitdiff_plain/1259fa280c5d6089056aeb83b3fdbcb2ef133be5 [lice @ more rearranging. define-key modifications to accomodate bindings.lisp. this braeks some bindings that didn't use the same name as emacs.] --- diff --git a/src/buffer-local.lisp b/src/buffer-local.lisp index 551701a..b2e652e 100644 --- a/src/buffer-local.lisp +++ b/src/buffer-local.lisp @@ -122,6 +122,10 @@ The default value is seen in buffers that do not have their own values for this variable." (setf (default-value symbol) value)) +(defmacro setq-default (var value) + "Set the default value of variable var to value." + `(setf (default-value ',var) ,value)) + ;;; Some built-in buffer local variables diff --git a/src/buffer.lisp b/src/buffer.lisp index 1a4021e..edf2175 100644 --- a/src/buffer.lisp +++ b/src/buffer.lisp @@ -588,6 +588,21 @@ means that other_buffer is more likely to choose a relevant buffer." (when (buffer-read-only) (signal 'buffer-read-only))) +(defun buffer-modified-p (&optional (buffer (current-buffer))) + "Return t if BUFFER was modified since its file was last read or saved. +No argument or nil as argument means use current buffer as BUFFER." + (slot-value buffer 'modified-p)) + +(defun (setf buffer-modified-p) (flag &optional (buf (current-buffer))) + "Mark current buffer as modified or unmodified according to FLAG. +A non-nil FLAG means mark the buffer modified." + (setf (slot-value buf 'modified-p) (and flag t))) + +(defun set-buffer-modified-p (flag) + "Mark current buffer as modified or unmodified according to FLAG. +A non-nil FLAG means mark the buffer modified." + (setf (buffer-modified-p) flag)) + (defun bufferp (object) "Return t if object is an editor buffer." (typep object 'buffer)) @@ -673,7 +688,9 @@ Note that this is overridden by the variable and this buffer is not full-frame width.") (make-variable-buffer-local 'truncate-lines) - +(define-buffer-local case-fold-search nil + "*Non-nil if searches and matches should ignore case.") +(make-variable-buffer-local 'case-fold-search) (defun make-buffer-string (start end props &optional (buffer (current-buffer))) "Making strings from buffer contents. @@ -703,4 +720,9 @@ buffer substrings." (buffer-char-to-aref buffer start) (1+ (buffer-char-to-aref buffer (1- end))))))) +;;; Key bindings + +(define-key *ctl-x-map* "b" 'switch-to-buffer) +(define-key *ctl-x-map* "k" 'kill-buffer) + (provide :lice-0.1/buffer) diff --git a/src/callproc.lisp b/src/callproc.lisp new file mode 100644 index 0000000..259b82c --- /dev/null +++ b/src/callproc.lisp @@ -0,0 +1,57 @@ +;; Synchronous subprocess invocation for GNU Emacs. + +(in-package "LICE") + +;; FIXME: Fill these with real values + +(defvar shell-file-name nil +"*File name to load inferior shells from. +Initialized from the SHELL environment variable, or to a system-dependent +default if SHELL is not set.") + +(defvar exec-path nil +"*List of directories to search programs to run in subprocesses. +Each element is a string (directory name) or nil (try default directory).") + +(defvar exec-suffixes nil +"*List of suffixes to try to find executable file names. +Each element is a string.") + Vexec_suffixes = Qnil; + +(defvar exec-directory nil +"Directory for executables for Emacs to invoke. +More generally, this includes any architecture-dependent files +that are built and installed from the Emacs distribution.") + +(defvar data-directory nil +"Directory of machine-independent files that come with GNU Emacs. +These are files intended for Emacs to use while it runs.") + +(defvar doc-directory nil +"Directory containing the DOC file that comes with GNU Emacs. +This is usually the same as `data-directory'.") + +(defvar configure-info-directory nil +"For internal use by the build procedure only. +This is the name of the directory in which the build procedure installed +Emacs's info files; the default value for `Info-default-directory-list' +includes this.") + +(defvar shared-game-score-directory nil +"Directory of score files for games which come with GNU Emacs. +If this variable is nil, then Emacs is unable to use a shared directory.") + +(defvar temp-file-name-pattern nil +"Pattern for making names for temporary files. +This is used by `call-process-region'.") + +(defvar process-environment nil +"List of environment variables for subprocesses to inherit. +Each element should be a string of the form ENVVARNAME=VALUE. +If multiple entries define the same variable, the first one always +takes precedence. +The environment which Emacs inherits is placed in this variable +when Emacs starts. +Non-ASCII characters are encoded according to the initial value of +`locale-coding-system', i.e. the elements must normally be decoded for use. +See `setenv' and `getenv'.") diff --git a/src/casefiddle.lisp b/src/casefiddle.lisp index 6b7d8be..deedaab 100644 --- a/src/casefiddle.lisp +++ b/src/casefiddle.lisp @@ -33,9 +33,11 @@ The argument object is not altered--the value is a copy." (defun upcase-region (beg end) (declare (ignore beg end)) (error "Unimplemented")) +(setf (get 'upcase-region 'disabled) t) (defun downcase-region () (error "Unimplemented")) +(setf (get 'downcase-region 'disabled) t) (defun capitalize-region () (error "Unimplemented")) @@ -51,3 +53,11 @@ The argument object is not altered--the value is a copy." (defun capitalize-word () (error "Unimplemented")) + +;;; Key bindings + +(define-key *ctl-x-map* "C-u" 'upcase-region) +(define-key *ctl-x-map* "C-l" 'downcase-region) +(define-key *global-map* "M-u" 'upcase-word) +(define-key *global-map* "M-l" 'downcase-word) +(define-key *global-map* "M-c" 'capitalize-word) diff --git a/src/cmds.lisp b/src/cmds.lisp index 768d4ed..cfea3c6 100644 --- a/src/cmds.lisp +++ b/src/cmds.lisp @@ -96,3 +96,26 @@ Whichever character you type to run this command is inserted." (when (> arg 0) (insert-move-point (current-buffer) (key-char *current-event*))))) +;;; Key bindings + +(define-key *global-map* "C-i" 'self-insert-command) + +(loop for i in '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 + #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j + #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t + #\u #\v #\w #\x #\y #\z + #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J + #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T + #\U #\V #\W #\X #\Y #\Z + #\Space #\! #\" #\# #\$ #\% #\& #\' #\( + #\) #\* #\+ #\, #\- #\. #\/ #\: #\; #\< + #\= #\> #\? #\@ #\[ #\\ #\] #\^ #\_ #\` + #\| #\} #\~ #\{) + do (define-key *global-map* (make-key :char i) 'self-insert-command)) + +(define-key *global-map* "C-a" 'beginning-of-line) +(define-key *global-map* "C-b" 'backward-char) +(define-key *global-map* "C-d" 'delete-char) +(define-key *global-map* "C-e" 'end-of-line) +(define-key *global-map* "C-f" 'forward-char) +(define-key *global-map* "DEL" 'delete-backward-char) \ No newline at end of file diff --git a/src/data-types.lisp b/src/data-types.lisp index 7a8a5a2..13a7c42 100644 --- a/src/data-types.lisp +++ b/src/data-types.lisp @@ -68,7 +68,7 @@ ((file :type (or null pathname) :initarg :file :accessor buffer-file) (name :type string :initarg :name :accessor buffer-name) (mode-line-string :type string :initform "" :accessor buffer-mode-line-string) - (modified :type boolean :initform nil :accessor buffer-modified-p) + (modified-p :type boolean :initform nil) (read-only :type boolean :initform nil) (tick :type integer :initform 0 :accessor buffer-modified-tick :documentation "The buffer's tick counter. It is incremented for each change diff --git a/src/data.lisp b/src/data.lisp new file mode 100644 index 0000000..3825e66 --- /dev/null +++ b/src/data.lisp @@ -0,0 +1,45 @@ +;;; data.lisp --- compatibility functions from emacs + +(in-package "LICE") + +(defun % (number divisor) + "same as mod." + (mod number divisor)) + +(defun setcar (cell newcar) + "Set the car of cell to be newcar. Returns newcar." + (setf (car cell) newcar)) + +(depricate aset (setf aref)) +(defun aset (array idx newelt) + "Store into the element of ARRAY at index IDX the value NEWELT. +Return NEWELT. ARRAY may be a vector, a string, a char-table or a +bool-vector. IDX starts at 0." + (setf (aref array idx) newelt)) + +(defmacro defalias (to from &optional docstring) + "Set SYMBOL's function definition to DEFINITION, and return DEFINITION. +Associates the function with the current load file, if any. +The optional third argument DOCSTRING specifies the documentation string +for SYMBOL; if it is omitted or nil, SYMBOL uses the documentation string +determined by DEFINITION." + ;; FIXME: implement + (declare (ignore to from docstring))) + +(defun plist-get (plist prop) + "Extract a value from a property list. +PLIST is a property list, which is a list of the form +\(PROP1 VALUE1 PROP2 VALUE2...). This function returns the value +corresponding to the given PROP, or nil if PROP is not +one of the properties on the list." + (getf plist prop)) + +(defun sequencep (object) + "Return t if OBJECT is a sequence (list or array)." + (typep object 'sequence)) + +(defun copy-sequence (seq) + "Return a copy of a list, vector, string or char-table. +The elements of a list or vector are not copied; they are shared +with the original." + (copy-seq seq)) diff --git a/src/debugger.lisp b/src/debugger.lisp index 9bf7562..ef50a86 100644 --- a/src/debugger.lisp +++ b/src/debugger.lisp @@ -2,12 +2,6 @@ (in-package "LICE") -(defvar *debug-on-error* t - "Non-nil means enter the debugger if an unhandled error is signaled.") - -(defvar *debug-on-quit* nil - "Non-nil means enter the debugger if quit is signaled (C-g, for example).") - (defvar *debugger-mode* (make-instance 'major-mode :name "Debugger" diff --git a/src/dired.lisp b/src/dired.lisp new file mode 100644 index 0000000..8d32268 --- /dev/null +++ b/src/dired.lisp @@ -0,0 +1,28 @@ +;;; Lisp functions for making directory listings. + +(in-package "LICE") + +(defvar completion-ignored-extensions nil + "Completion ignores file names ending in any string in this list. +It does not ignore them if all possible completions end in one of +these strings or when displaying a list of completions. +It ignores directory names if they match any string in this list which +ends in a slash.") + +(defun directory-files () + (error "unimplemented")) + +(defun directory-files-and-attributes () + (error "unimplemented")) + +(defun file-name-completion () + (error "unimplemented")) + +(defun file-name-all-completions () + (error "unimplemented")) + +(defun file-attributes () + (error "unimplemented")) + +(defun file-attributes-lessp () + (error "unimplemented")) diff --git a/src/editfns.lisp b/src/editfns.lisp index 166234b..6969019 100644 --- a/src/editfns.lisp +++ b/src/editfns.lisp @@ -490,8 +490,10 @@ This function does not move point." A multibyte character is handled correctly." (char string 0)) -(defun char-to-string () - (error "Unimplemented")) +(defun char-to-string (char) +"Convert arg CHAR to a string containing that character. +usage: (char-to-string CHAR)" + (string char)) (defun buffer-string () (error "Unimplemented")) diff --git a/src/elisp.lisp b/src/elisp.lisp index 9ead271..4314a71 100644 --- a/src/elisp.lisp +++ b/src/elisp.lisp @@ -1,8 +1,8 @@ (cl:defpackage "ELISP" (:nicknames "EL") (:use "CL") - (:shadow cl:if) - (:export #:if)) + (:shadow cl:if cl:defun) + (:export #:if #:defun)) (in-package "ELISP") @@ -13,3 +13,21 @@ (progn ,@else))) + +(cl:defun parse-interactive (thing) + (error "unimplemented")) + +(defmacro defun (name lambda-list &body body) + "Parse an elisp style defun and convert it to a cl defun or lice defcommand." + (let ((doc (when (stringp (car body)) + (pop body))) + (decls (loop while (eq (caar body) 'declare) + collect (pop body))) + (interactive (when (and (listp (car body)) + (eq (caar body) 'interactive)) + (pop body)))) + (if interactive + `(defcommand ,name (,lambda-list + ,@(parse-interactive (cdr interactive))) + ,@(append (list doc) decls body)) + `(cl:defun ,name ,@(append (list doc) decls body))))) diff --git a/src/emacs-lisp/easy-mmode.lisp b/src/emacs-lisp/easy-mmode.lisp new file mode 100644 index 0000000..4891217 --- /dev/null +++ b/src/emacs-lisp/easy-mmode.lisp @@ -0,0 +1,520 @@ +;;; easy-mmode.el --- easy definition for major and minor modes + +;; Copyright (C) 1997, 2000, 2001, 2002, 2003, 2004, 2005, +;; 2006 Free Software Foundation, Inc. + +;; Author: Georges Brun-Cottan +;; Maintainer: Stefan Monnier + +;; Keywords: extensions lisp + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;; Minor modes are useful and common. This package makes defining a +;; minor mode easy, by focusing on the writing of the minor mode +;; functionalities themselves. Moreover, this package enforces a +;; conventional naming of user interface primitives, making things +;; natural for the minor-mode end-users. + +;; For each mode, easy-mmode defines the following: +;; : The minor mode predicate. A buffer-local variable. +;; -map : The keymap possibly associated to . +;; see `define-minor-mode' documentation +;; +;; eval +;; (pp (macroexpand '(define-minor-mode ))) +;; to check the result before using it. + +;; The order in which minor modes are installed is important. Keymap +;; lookup proceeds down minor-mode-map-alist, and the order there +;; tends to be the reverse of the order in which the modes were +;; installed. Perhaps there should be a feature to let you specify +;; orderings. + +;; Additionally to `define-minor-mode', the package provides convenient +;; ways to define keymaps, and other helper functions for major and minor modes. + +;;; Code: + +(in-package "LICE") + +(defun easy-mmode-pretty-mode-name (mode &optional lighter) + "Turn the symbol MODE into a string intended for the user. +If provided, LIGHTER will be used to help choose capitalization by, +replacing its case-insensitive matches with the literal string in LIGHTER." + (let* ((case-fold-search t) + ;; Produce "Foo-Bar minor mode" from foo-bar-minor-mode. + (name (concat (replace-regexp-in-string + ;; If the original mode name included "-minor" (some + ;; of them don't, e.g. auto-revert-mode), then + ;; replace it with " minor". + "-Minor" " minor" + ;; "foo-bar-minor" -> "Foo-Bar-Minor" + (capitalize (replace-regexp-in-string + ;; "foo-bar-minor-mode" -> "foo-bar-minor" + "-mode\\'" "" (symbol-name mode)))) + " mode"))) + (el:if (not (stringp lighter)) name + ;; Strip leading and trailing whitespace from LIGHTER. + (setq lighter (replace-regexp-in-string "\\`\\s-+\\|\\s-+\\'" "" + lighter)) + ;; Replace any (case-insensitive) matches for LIGHTER in NAME + ;; with a literal LIGHTER. E.g., if NAME is "Iimage mode" and + ;; LIGHTER is " iImag", then this will produce "iImage mode". + ;; (LIGHTER normally comes from the mode-line string passed to + ;; define-minor-mode, and normally includes at least one leading + ;; space.) + (replace-regexp-in-string (regexp-quote lighter) lighter name t t)))) + +;;;###autoload +(defalias 'easy-mmode-define-minor-mode 'define-minor-mode) +;;;###autoload +(defmacro define-minor-mode ((mode doc ;;&optional init-value lighter keymap + &key init-value lighter ((:global globalp)) extra-args set + initialize group type (require t) keymap) + ;; FIXME: in the original any keys not + ;; above were added to extra-keywords, + ;; but i'm too lazy to do it that way + ;; atm. -sabetts + extra-keywords + &body body) + "Define a new minor mode MODE. +This function defines the associated control variable MODE, keymap MODE-map, +and toggle command MODE. + +DOC is the documentation for the mode toggle command. +Optional INIT-VALUE is the initial value of the mode's variable. +Optional LIGHTER is displayed in the modeline when the mode is on. +Optional KEYMAP is the default (defvar) keymap bound to the mode keymap. + If it is a list, it is passed to `easy-mmode-define-keymap' + in order to build a valid keymap. It's generally better to use + a separate MODE-map variable than to use this argument. +The above three arguments can be skipped if keyword arguments are +used (see below). + +BODY contains code to execute each time the mode is activated or deactivated. + It is executed after toggling the mode, + and before running the hook variable `mode-HOOK'. + Before the actual body code, you can write keyword arguments (alternating + keywords and values). These following keyword arguments are supported (other + keywords will be passed to `defcustom' if the minor mode is global): +:group GROUP Custom group name to use in all generated `defcustom' forms. + Defaults to MODE without the possible trailing \"-mode\". + Don't use this default group name unless you have written a + `defgroup' to define that group properly. +:global GLOBAL If non-nil specifies that the minor mode is not meant to be + buffer-local, so don't make the variable MODE buffer-local. + By default, the mode is buffer-local. +:init-value VAL Same as the INIT-VALUE argument. +:lighter SPEC Same as the LIGHTER argument. +:keymap MAP Same as the KEYMAP argument. +:require SYM Same as in `defcustom'. + +For example, you could write + (define-minor-mode foo-mode \"If enabled, foo on you!\" + :lighter \" Foo\" :require 'foo :global t :group 'hassle :version \"27.5\" + ...BODY CODE...)" + (let* ((last-message (current-message)) + (mode-name (symbol-name mode)) + (pretty-name (easy-mmode-pretty-mode-name mode lighter)) + (hook (intern (concat mode-name "-hook"))) + (hook-on (intern (concat mode-name "-on-hook"))) + (hook-off (intern (concat mode-name "-off-hook"))) + keymap-sym) + +;; ;; Check keys. +;; (while (keywordp (setq keyw (car body))) +;; (setq body (cdr body)) +;; (case keyw +;; (:init-value (setq init-value (pop body))) +;; (:lighter (setq lighter (pop body))) +;; (:global (setq globalp (pop body))) +;; (:extra-args (setq extra-args (pop body))) +;; (:set (setq set (list :set (pop body)))) +;; (:initialize (setq initialize (list :initialize (pop body)))) +;; (:group (setq group (nconc group (list :group (pop body))))) +;; (:type (setq type (list :type (pop body)))) +;; (:require (setq require (pop body))) +;; (:keymap (setq keymap (pop body))) +;; (t (push keyw extra-keywords) (push (pop body) extra-keywords)))) + + ;; XXX: :group can occur many times in the original. here only once. + (setf keymap-sym (if (and keymap (symbolp keymap)) keymap + (intern (concat mode-name "-MAP"))) + set `(:set ,(or set 'custom-set-minor-mode)) + initialize `(:initialize ,(or initialize 'custom-initialize-default)) + ;; We might as well provide a best-guess default group. + group `(:group (or ,group '(intern (replace-regexp-in-string + "-mode\\'" "" mode-name)))) + type `(:type ,(or type 'boolean))) + + `(progn + ;; Define the variable to enable or disable the mode. + ,(if (not globalp) + `(progn + (define-buffer-local ,mode ,init-value ,(format "Non-nil if %s is enabled. +Use the command `%s' to change this variable." pretty-name mode)) + (make-variable-buffer-local ',mode)) + + (let ((base-doc-string + (concat "Non-nil if %s is enabled. +See the command `%s' for a description of this minor-mode." + (if body " +Setting this variable directly does not take effect; +use either \\[customize] or the function `%s'.")))) + `(defcustom ,mode ,init-value + ,(format base-doc-string pretty-name mode mode) + ,@set + ,@initialize + ,@group + ,@type + ,@(unless (eq require t) `(:require ,require)) + ,@(nreverse extra-keywords)))) + + ;; The actual function. + (defcommand ,mode ((&optional arg ,@extra-args) + :raw-prefix) + ,(or doc + (format nil (concat "Toggle ~a on or off. +Interactively, with no prefix argument, toggle the mode. +With universal prefix ARG turn mode on. +With zero or negative ARG turn mode off. +\\{~s}") pretty-name keymap-sym)) + ;; Use `toggle' rather than (if ,mode 0 1) so that using + ;; repeat-command still does the toggling correctly. + ;;(interactive (list (or current-prefix-arg 'toggle))) + (unless arg (setf arg 'toggle)) + (setq ,mode + (cond + ((eq arg 'toggle) (not ,mode)) + (arg (> (prefix-numeric-value arg) 0)) + (t + (el:if (null ,mode) t + (message + "Toggling %s off; better pass an explicit argument." + ',mode) + nil)))) + ,@body + ;; The on/off hooks are here for backward compatibility only. + (run-hooks ',hook (if ,mode ',hook-on ',hook-off)) + (if (called-interactively-p) + (progn + ,(if globalp `(customize-mark-as-set ',mode)) + ;; Avoid overwriting a message shown by the body, + ;; but do overwrite previous messages. + (unless ,(and (current-message) + (not (equal last-message (current-message)))) + (message ,(format "~a ~~aabled" pretty-name) + (if ,mode "en" "dis"))))) + (force-mode-line-update) + ;; Return the new setting. + ,mode) + + ;; XXX: What do we do with this? -sabetts +;; ;; Autoloading a define-minor-mode autoloads everything +;; ;; up-to-here. +;; :autoload-end + + ;; Define the minor-mode keymap. + ,(unless (symbolp keymap) ;nil is also a symbol. + `(defvar ,keymap-sym + (let ((m ,keymap)) + (cond ((keymapp m) m) + ((listp m) (easy-mmode-define-keymap m)) + (t (error "Invalid keymap %S" ,keymap)))) + ,(format nil "Keymap for `~s'." mode-name))) + + (add-minor-mode ',mode ',lighter + ,(if keymap keymap-sym + `(if (boundp ',keymap-sym) + (symbol-value ',keymap-sym))))))) + +;;; +;;; make global minor mode +;;; + +;;;###autoload +(defalias 'easy-mmode-define-global-mode 'define-global-minor-mode) +;;;###autoload +(defmacro define-global-minor-mode (global-mode mode turn-on &rest keys) + "Make GLOBAL-MODE out of the buffer-local minor MODE. +TURN-ON is a function that will be called with no args in every buffer + and that should try to turn MODE on if applicable for that buffer. +KEYS is a list of CL-style keyword arguments. As the minor mode + defined by this function is always global, any :global keyword is + ignored. Other keywords have the same meaning as in `define-minor-mode', + which see. In particular, :group specifies the custom group. + The most useful keywords are those that are passed on to the + `defcustom'. It normally makes no sense to pass the :lighter + or :keymap keywords to `define-global-minor-mode', since these + are usually passed to the buffer-local version of the minor mode. + +If MODE's set-up depends on the major mode in effect when it was +enabled, then disabling and reenabling MODE should make MODE work +correctly with the current major mode. This is important to +prevent problems with derived modes, that is, major modes that +call another major mode in their body." + + (let* ((global-mode-name (symbol-name global-mode)) + (pretty-name (easy-mmode-pretty-mode-name mode)) + (pretty-global-name (easy-mmode-pretty-mode-name global-mode)) + (group nil) + (extra-keywords nil) + (MODE-buffers (intern (concat global-mode-name "-buffers"))) + (MODE-enable-in-buffers + (intern (concat global-mode-name "-enable-in-buffers"))) + (MODE-check-buffers + (intern (concat global-mode-name "-check-buffers"))) + (MODE-cmhh (intern (concat global-mode-name "-cmhh"))) + (MODE-major-mode (intern (concat (symbol-name mode) "-major-mode"))) + keyw) + + ;; Check keys. + (while (keywordp (setq keyw (car keys))) + (setq keys (cdr keys)) + (case keyw + (:group (setq group (nconc group (list :group (pop keys))))) + (:global (setq keys (cdr keys))) + (t (push keyw extra-keywords) (push (pop keys) extra-keywords)))) + + (unless group + ;; We might as well provide a best-guess default group. + (setq group + `(:group ',(intern (replace-regexp-in-string + "-mode\\'" "" (symbol-name mode)))))) + + `(progn + (defvar ,MODE-major-mode nil) + (make-variable-buffer-local ',MODE-major-mode) + ;; The actual global minor-mode + (define-minor-mode ,global-mode + ,(format "Toggle %s in every buffer. +With prefix ARG, turn %s on if and only if ARG is positive. +%s is actually not turned on in every buffer but only in those +in which `%s' turns it on." + pretty-name pretty-global-name pretty-name turn-on) + :global t ,@group ,@(nreverse extra-keywords) + + ;; Setup hook to handle future mode changes and new buffers. + (el:if ,global-mode + (progn + (add-hook 'after-change-major-mode-hook + ',MODE-enable-in-buffers) + (add-hook 'find-file-hook ',MODE-check-buffers) + (add-hook 'change-major-mode-hook ',MODE-cmhh)) + (remove-hook 'after-change-major-mode-hook ',MODE-enable-in-buffers) + (remove-hook 'find-file-hook ',MODE-check-buffers) + (remove-hook 'change-major-mode-hook ',MODE-cmhh)) + + ;; Go through existing buffers. + (dolist (buf (buffer-list)) + (with-current-buffer buf + (if ,global-mode (,turn-on) (when ,mode (,mode -1)))))) + + ;; Autoloading define-global-minor-mode autoloads everything + ;; up-to-here. + :autoload-end + + ;; List of buffers left to process. + (defvar ,MODE-buffers nil) + + ;; The function that calls TURN-ON in each buffer. + (defun ,MODE-enable-in-buffers () + (dolist (buf ,MODE-buffers) + (when (buffer-live-p buf) + (with-current-buffer buf + (el:if ,mode + (unless (eq ,MODE-major-mode major-mode) + (,mode -1) + (,turn-on) + (setq ,MODE-major-mode major-mode)) + (,turn-on) + (setq ,MODE-major-mode major-mode)))))) + (put ',MODE-enable-in-buffers 'definition-name ',global-mode) + + (defun ,MODE-check-buffers () + (,MODE-enable-in-buffers) + (setq ,MODE-buffers nil) + (remove-hook 'post-command-hook ',MODE-check-buffers)) + (put ',MODE-check-buffers 'definition-name ',global-mode) + + ;; The function that catches kill-all-local-variables. + (defun ,MODE-cmhh () + (add-to-list ',MODE-buffers (current-buffer)) + (add-hook 'post-command-hook ',MODE-check-buffers)) + (put ',MODE-cmhh 'definition-name ',global-mode)))) + +;;; +;;; easy-mmode-defmap +;;; + +(if (fboundp 'set-keymap-parents) + (defalias 'easy-mmode-set-keymap-parents 'set-keymap-parents) + (defun easy-mmode-set-keymap-parents (m parents) + (set-keymap-parent + m + (cond + ((not (consp parents)) parents) + ((not (cdr parents)) (car parents)) + (t (let ((m (copy-keymap (pop parents)))) + (easy-mmode-set-keymap-parents m parents) + m)))))) + +;;;###autoload +(defun easy-mmode-define-keymap (bs &optional name m args) + "Return a keymap built from bindings BS. +BS must be a list of (KEY . BINDING) where +KEY and BINDINGS are suitable for `define-key'. +Optional NAME is passed to `make-sparse-keymap'. +Optional map M can be used to modify an existing map. +ARGS is a list of additional keyword arguments." + (let (inherit dense) + (while args + (let ((key (pop args)) + (val (pop args))) + (case key + (:name (setq name val)) + (:dense (setq dense val)) + (:inherit (setq inherit val)) + (:group) + (t (message "Unknown argument %s in defmap" key))))) + (unless (keymapp m) + (setq bs (append m bs)) + (setq m (if dense (make-keymap name) (make-sparse-keymap name)))) + (dolist (b bs) + (let ((keys (car b)) + (binding (cdr b))) + (dolist (key (if (consp keys) keys (list keys))) + (cond + ((symbolp key) + (substitute-key-definition key binding m *global-map*)) + ((null binding) + (unless (keymapp (lookup-key m key)) (define-key m key binding))) + ((let ((o (lookup-key m key))) + (or (null o) (numberp o) (eq o 'undefined))) + (define-key m key binding)))))) + (cond + ((keymapp inherit) (set-keymap-parent m inherit)) + ((consp inherit) (easy-mmode-set-keymap-parents m inherit))) + m)) + +;;;###autoload +(defmacro easy-mmode-defmap (m bs doc &rest args) + `(defconst ,m + (easy-mmode-define-keymap ,bs nil (if (boundp ',m) ,m) ,(cons 'list args)) + ,doc)) + + +;;; +;;; easy-mmode-defsyntax +;;; + +(defun easy-mmode-define-syntax (css args) + (let ((st (make-syntax-table (plist-get args :copy))) + (parent (plist-get args :inherit))) + (dolist (cs css) + (let ((char (car cs)) + (syntax (cdr cs))) + (if (sequencep char) + (mapcar (lambda (c) (modify-syntax-entry c syntax st)) char) + (modify-syntax-entry char syntax st)))) + (if parent (set-char-table-parent + st (if (symbolp parent) (symbol-value parent) parent))) + st)) + +;;;###autoload +(defmacro easy-mmode-defsyntax (st css doc &rest args) + "Define variable ST as a syntax-table. +CSS contains a list of syntax specifications of the form (CHAR . SYNTAX)." + `(progn + (autoload 'easy-mmode-define-syntax "easy-mmode") + (defconst ,st (easy-mmode-define-syntax ,css ,(cons 'list args)) ,doc))) + + + +;;; +;;; easy-mmode-define-navigation +;;; + +(defmacro easy-mmode-define-navigation (base re &optional name endfun narrowfun) + "Define BASE-next and BASE-prev to navigate in the buffer. +RE determines the places the commands should move point to. +NAME should describe the entities matched by RE. It is used to build + the docstrings of the two functions. +BASE-next also tries to make sure that the whole entry is visible by + searching for its end (by calling ENDFUN if provided or by looking for + the next entry) and recentering if necessary. +ENDFUN should return the end position (with or without moving point). +NARROWFUN non-nil means to check for narrowing before moving, and if +found, do widen first and then call NARROWFUN with no args after moving." + (let* ((base-name (symbol-name base)) + (prev-sym (intern (concat base-name "-prev"))) + (next-sym (intern (concat base-name "-next"))) + (check-narrow-maybe + (when narrowfun + '(setq was-narrowed + (prog1 (or (< (- (point-max) (point-min)) (buffer-size))) + (widen))))) + (re-narrow-maybe (when narrowfun + `(when was-narrowed (,narrowfun))))) + (unless name (setq name base-name)) + `(progn + (add-to-list 'debug-ignored-errors + ,(concat "^No \\(previous\\|next\\) " (regexp-quote name))) + (defun ,next-sym (&optional count) + ,(format "Go to the next COUNT'th %s." name) + (interactive) + (unless count (setq count 1)) + (el:if (< count 0) (,prev-sym (- count)) + (if (looking-at ,re) (setq count (1+ count))) + (let (was-narrowed) + ,check-narrow-maybe + (if (not (re-search-forward ,re nil t count)) + (if (looking-at ,re) + (goto-char (or ,(if endfun `(,endfun)) (point-max))) + (error "No next %s" ,name)) + (goto-char (match-beginning 0)) + (when (and (eq (current-buffer) (window-buffer (selected-window))) + (interactive-p)) + (let ((endpt (or (save-excursion + ,(if endfun `(,endfun) + `(re-search-forward ,re nil t 2))) + (point-max)))) + (unless (pos-visible-in-window-p endpt nil t) + (recenter '(0)))))) + ,re-narrow-maybe))) + (put ',next-sym 'definition-name ',base) + (defun ,prev-sym (&optional count) + ,(format "Go to the previous COUNT'th %s" (or name base-name)) + (interactive) + (unless count (setq count 1)) + (if (< count 0) (,next-sym (- count)) + (let (was-narrowed) + ,check-narrow-maybe + (unless (re-search-backward ,re nil t count) + (error "No previous %s" ,name)) + ,re-narrow-maybe))) + (put ',prev-sym 'definition-name ',base)))) + + +(provide 'easy-mmode) + +;;; arch-tag: d48a5250-6961-4528-9cb0-3c9ea042a66a +;;; easy-mmode.el ends here \ No newline at end of file diff --git a/src/emacs.lisp b/src/emacs.lisp new file mode 100644 index 0000000..e2f9f46 --- /dev/null +++ b/src/emacs.lisp @@ -0,0 +1,16 @@ +(in-package "LICE") + +;; FIXME: figure out the system type +(defvar system-type :undefined + "Value is symbol indicating type of operating system you are using. +Special values: + `:gnu/linux' compiled for a GNU/Linux system. + `:darwin' compiled for Darwin (GNU-Darwin, Mac OS X, ...). + `:macos' compiled for Mac OS 9. + `:ms-dos' compiled as an MS-DOS application. + `:windows-nt' compiled as a native W32 application. + `:cygwin' compiled using the Cygwin library. + `:vax-vms' or + `:axp-vms' compiled for a (Open)VMS system. +Anything else indicates some sort of Unix system. */); + Vsystem_type = intern (SYSTEM_TYPE") diff --git a/src/fns.lisp b/src/fns.lisp new file mode 100644 index 0000000..dd64c69 --- /dev/null +++ b/src/fns.lisp @@ -0,0 +1,41 @@ +;;; fns.lisp --- compatibility function from emacs + +(in-package "LICE") + +(defun concat (&rest strings) + "Concatenate all the arguments and make the result a string. +The result is a string whose elements are the elements of all the arguments. +Each argument must be a string." + (apply 'concatenate 'string strings)) + +(defun cdr-safe (object) + "Return the cdr of OBJECT if it is a cons cell, or else nil." + (when (consp object) + (cdr object))) + +;; XXX: get rid of this function and all callers +(defun assq (prop list) + "Return non-nil if key is `eq' to the car of an element of list. +The value is actually the first element of list whose car is key. +Elements of list that are not conses are ignored." + (assoc prop (remove-if 'listp list))) + +(depricate substring subseq) +(defun substring (string from &optional (to (length string))) + "Return a substring of string, starting at index from and ending before to. +to may be nil or omitted; then the substring runs to the end of string. +from and to start at 0. If either is negative, it counts from the end. + +This function allows vectors as well as strings." + (when (< from 0) + (setf from (max 0 (+ (length string) from)))) + (when (< to 0) + (setf to (max 0 (+ (length string) to)))) + (subseq string from to)) + +(depricate memq member) +(defun memq (elt list) + "Return non-nil if ELT is an element of LIST. +Comparison done with `eq'. The value is actually the tail of LIST +whose car is ELT." + (member elt list :test 'eq)) diff --git a/src/global.lisp b/src/global.lisp index 3710141..d0b94f2 100644 --- a/src/global.lisp +++ b/src/global.lisp @@ -44,6 +44,9 @@ (define-condition lice-condition () () (:documentation "The base condition for all lice related errors.")) +(define-condition wrong-type-argument (lice-condition) + ((:type :initarg :type :accessor wrong-type-argument-type))) + ;; (defun fmt (fmt &rest args) ;; "A movitz hack function. FORMAT basically doesn't work, so i use this to get around it." ;; (let ((s (make-array 100 :fill-pointer 0 :element-type 'character))) @@ -58,12 +61,6 @@ ;;; Lisp function we like to have -(defun concat (&rest strings) - "Concatenate all the arguments and make the result a string. -The result is a string whose elements are the elements of all the arguments. -Each argument must be a string." - (apply 'concatenate 'string strings)) - (defmacro while (test &body body) "If TEST yields non-nil, eval BODY... and repeat. The order of execution is thus TEST, BODY, TEST, BODY and so on @@ -72,11 +69,6 @@ until TEST returns nil." `(loop while ,test do ,@body) `(loop while ,test))) -(defun cdr-safe (object) - "Return the cdr of OBJECT if it is a cons cell, or else nil." - (when (consp object) - (cdr object))) - (defvar *quit-code* 7 "The terminal char code for the interrupt key.") @@ -93,13 +85,6 @@ before making `inhibit-quit' nil.") (defvar *quit-flag* nil "Set to T when the user hit the quit key") - -;; XXX: get rid of this function and all callers -(defun assq (prop list) - "Return non-nil if key is `eq' to the car of an element of list. -The value is actually the first element of list whose car is key. -Elements of list that are not conses are ignored." - (assoc prop (remove-if 'listp list))) (defmacro depricate (symbol refer-to) "A macro to mark a symbol as depricated. This is done with @@ -178,26 +163,6 @@ the hook's buffer-local value rather than its default value." (declare (ignore local)) (setf (symbol-value hook) (remove function (symbol-value hook)))) -(depricate substring subseq) -(defun substring (string from &optional (to (length string))) - "Return a substring of string, starting at index from and ending before to. -to may be nil or omitted; then the substring runs to the end of string. -from and to start at 0. If either is negative, it counts from the end. - -This function allows vectors as well as strings." - (when (< from 0) - (setf from (max 0 (+ (length string) from)))) - (when (< to 0) - (setf to (max 0 (+ (length string) to)))) - (subseq string from to)) - -(depricate memq member) -(defun memq (elt list) - "Return non-nil if ELT is an element of LIST. -Comparison done with `eq'. The value is actually the tail of LIST -whose car is ELT." - (member elt list :test 'eq)) - (defun int-to-string (n) "Return the decimal representation of number as a string. Uses a minus sign if negative. @@ -253,10 +218,6 @@ not compute it, store the result, and return it." (cdr ,match) (memoize-store ,mem-var ,thing ,compute))))) -(defun % (number divisor) - "same as mod." - (mod number divisor)) - (defun add-to-list (list-var element &optional append) "Add ELEMENT to the value of LIST-VAR if it isn't there yet. The test for presence of ELEMENT is done with `equal'. @@ -285,16 +246,29 @@ other hooks, such as major mode hooks, can do the job." (defun ,name ,lambda-list ,@body))) -(defun setcar (cell newcar) - "Set the car of cell to be newcar. Returns newcar." - (setf (car cell) newcar)) -(depricate aset (setf aref)) -(defun aset (array idx newelt) - "Store into the element of ARRAY at index IDX the value NEWELT. -Return NEWELT. ARRAY may be a vector, a string, a char-table or a -bool-vector. IDX starts at 0." - (setf (aref array idx) newelt)) +(defvar *debug-on-error* t + "Non-nil means enter the debugger if an unhandled error is signaled.") + +(defvar *debug-on-quit* nil + "Non-nil means enter the debugger if quit is signaled (C-g, for example).") + +(defvar debug-ignored-errors nil + "*List of errors for which the debugger should not be called. +Each element may be a condition-name or a regexp that matches error messages. +If any element applies to a given error, that error skips the debugger +and just returns to top level. +This overrides the variable `debug-on-error'. +It does not apply to errors handled by `condition-case'.") + +(defun purecopy (thing) + "Make a copy of object OBJ in pure storage. +Recursively copies contents of vectors and cons cells. +Does not copy symbols. Copies strings without text properties." + thing) +(defun garbage-collect () + "Reclaim storage for Lisp objects no longer needed." + (warn "unimplemented")) (provide :lice-0.1/global) diff --git a/src/indent.lisp b/src/indent.lisp index 5e16867..f6ce2e9 100644 --- a/src/indent.lisp +++ b/src/indent.lisp @@ -2,6 +2,10 @@ (in-package "LICE") +(define-buffer-local indent-tabs-mode t +"*Indentation can insert tabs if this is non-nil. +Setting this variable automatically makes it local to the current buffer.") + (define-buffer-local *indent-line-function* 'indent-relative "Function to indent the current line. This function will be called with no arguments. diff --git a/src/keyboard.lisp b/src/keyboard.lisp index ae6d0ee..3ea2e02 100644 --- a/src/keyboard.lisp +++ b/src/keyboard.lisp @@ -2,6 +2,10 @@ (in-package "LICE") +(defvar help-event-list nil + "List of input events to recognize as meaning Help. +These work just like the value of `help-char' (see that).") + (define-condition quit (lice-condition) () (:documentation "A condition raised when the user aborted the operation (by pressing C-g, for instance).")) @@ -40,39 +44,43 @@ The value is a list of KEYs." (defun dispatch-command (name) (let* ((cmd (lookup-command name)) ;; (args (collect-command-args cmd)) - (*this-command* (command-name cmd)) + (*this-command* (and cmd (command-name cmd))) (*current-prefix-arg* *prefix-arg*)) (clear-minibuffer) - (restart-case - (handler-bind - ((quit - (lambda (c) - (if *debug-on-quit* - (signal c) - (invoke-restart 'abort-command)))) - (lice-condition - (lambda (c) - (if *debug-on-error* - (signal c) - (invoke-restart 'just-print-error c)))) - (error - (lambda (c) - (if *debug-on-error* - (signal c) - (invoke-restart 'just-print-error c))))) - (funcall (command-fn cmd))) - (abort-command () - :report "Abort the command." - (message "Quit")) - (just-print-error (c) - :report "Abort and print error." - ;; we need a bell - (message "~a" c))) - (setf *last-command* *this-command* - ;; reset command keys, since the command is over. - *this-command-keys* nil) - ;; handle undo - (undo-boundary))) + (if cmd + (progn + (restart-case + (handler-bind + ((quit + (lambda (c) + (if *debug-on-quit* + (signal c) + (invoke-restart 'abort-command)))) + (lice-condition + (lambda (c) + (if *debug-on-error* + (signal c) + (invoke-restart 'just-print-error c)))) + (error + (lambda (c) + (if *debug-on-error* + (signal c) + (invoke-restart 'just-print-error c))))) + (funcall (command-fn cmd))) + (abort-command () + :report "Abort the command." + (message "Quit")) + (just-print-error (c) + :report "Abort and print error." + ;; we need a bell + (message "~a" c))) + (setf *last-command* *this-command*) + ;; handle undo + (undo-boundary)) + ;; blink + (message "Symbol's command is void: ~a" name) + ;; reset command keys, since the command is over. + *this-command-keys* nil))) ;;; events @@ -91,19 +99,19 @@ events that invoked the current command." (pop *unread-command-events*) (wait-for-event))) (def (if *current-kmap* - (lookup-key-internal *current-kmap* *current-event* t *current-keymap-theme* t) + (lookup-key-internal *current-kmap* *current-event* t *current-keymap-theme* t nil t) ;; no current kmap? (or (when *overriding-terminal-local-map* - (lookup-key-internal *overriding-terminal-local-map* *current-event* t *current-keymap-theme* t)) + (lookup-key-internal *overriding-terminal-local-map* *current-event* t *current-keymap-theme* t nil t)) (when *overriding-local-map* - (lookup-key-internal *overriding-local-map* *current-event* t *current-keymap-theme* t)) + (lookup-key-internal *overriding-local-map* *current-event* t *current-keymap-theme* t nil t)) (when (current-local-map) - (lookup-key-internal (current-local-map) *current-event* t *current-keymap-theme* t)) + (lookup-key-internal (current-local-map) *current-event* t *current-keymap-theme* t nil t)) ;;(lookup-key-internal (major-mode-map (major-mode)) *current-event* t *current-keymap-theme* t) ;; TODO: minor mode maps ;; check the global map - (lookup-key-internal *global-map* *current-event* t *current-keymap-theme* t))))) + (lookup-key-internal *global-map* *current-event* t *current-keymap-theme* t nil t))))) (dformat +debug-v+ "~a ~s ~a~%" def #|(key-hashid *current-event*)|# *current-event* (key-char *current-event*)) (if def @@ -177,4 +185,12 @@ events that invoked the current command." (catch :unbound-key (next-event))) +;;; Key bindings + +(define-key *global-map* "C-z" 'suspend-emacs) +(define-key *ctl-x-map* "C-z" 'suspend-emacs) +(define-key *global-map* "M-C-c" 'exit-recursive-edit) +(define-key *global-map* "C-]" 'abort-recursive-edit) +(define-key *global-map* "M-x" 'execute-extended-command) + (provide :lice-0.1/input) diff --git a/src/keymap.lisp b/src/keymap.lisp index 3040ee0..67005e1 100644 --- a/src/keymap.lisp +++ b/src/keymap.lisp @@ -2,6 +2,9 @@ (in-package "LICE") +;; for mouse click events +(defstruct click where button) + (defstruct key char control meta alt shift hyper super) ;; (defclass key () ;; ((char :type character :initarg :char :reader key-char) @@ -49,11 +52,27 @@ for passing as the last argument to (apply #'make-key ...)" (#\S (list :shift t)) (t (signal 'kbd-parse)))))) +(defvar *keysyms* nil + "An alist of keysyms that map a string to either a character or a symbol.") + +(defmacro define-keysym (string thing) + `(pushnew (cons ,string ,thing) *keysyms* :test 'equal)) + +(define-keysym "RET" #\Newline) +(define-keysym "TAB" #\Tab) +(define-keysym "SPC" #\Space) + +(define-keysym "up" :up) +(define-keysym "down" :down) +(define-keysym "left" :left) +(define-keysym "right" :right) +(define-keysym "prior" :prior) + (defun parse-char-name (string) "Return the character whose name is STRING." - (or (cond - ((string= string "RET") #\Newline) - ((string= string "TAB") #\Tab)) + (or (let ((sym (find string *keysyms* :test 'string= :key 'car))) + (when sym + (cdr sym))) (name-char string) (and (= (length string) 1) (char string 0)))) @@ -129,23 +148,57 @@ in case you use it as a menu with `x-popup-menu'." (or (get-keymap-theme keymap theme) (setf (gethash theme (keymap-themes keymap)) (make-hash-table :size 200 :test 'equalp)))) -(defun define-key (keymap key def &optional (theme :lice)) +(defgeneric define-key (keymap key def &optional theme) + (:documentation "In keymap, define key sequence key as def. +keymap is a keymap.")) + +(defmethod define-key (keymap (key vector) def &optional (theme :lice)) + "for some weirdness in bindings.lisp" + (warn "unimplemented")) + +(defmethod define-key (keymap (key click) def &optional (theme :lice)) + "Mouse click events" + (warn "unimplemented")) + +(defmethod define-key (keymap (key string) (def string) &optional (theme :lice)) + "alias a key to another key." + (warn "unimplemented")) + +(defmethod define-key (keymap (key symbol) def &optional (theme :lice)) + "Special events are represented as symbols." + (warn "unimplemented")) + +(defmethod define-key (keymap (key string) def &optional (theme :lice)) + (define-key keymap (parse-key-seq key) def theme)) + +(defmethod define-key (keymap (key list) def &optional (theme :lice)) + (let ((map (lookup-key-internal keymap key nil theme nil t nil))) + ;; FIXME: do this error properly + (unless map (error "Key sequence %s starts with non-prefix key %s")) + (define-key map (car (last key)) def theme))) + +(defmethod define-key (keymap (key key) def &optional (theme :lice)) (let ((map (get-keymap-theme-create keymap theme))) (setf (gethash #|(key-hashid key)|# key map) def))) -(defun lookup-key-internal (keymap key accept-default theme norecurse) +(defun lookup-key-internal (keymap key accept-default theme norecurse return-kmap check-parents) + "RETURN-KMAP means return the key's keymap." (let* ((map (get-keymap-theme keymap theme)) ;; some maps may not have a hash table for the theme. - (cmd (and map (gethash #|(key-hashid key)|# key map)))) + (cmd (and map (gethash (if (consp key) (car key) key) + map)))) (or ;; if the binding is another keymap, then lookup the rest of the key sequence (cond + ((and return-kmap + (= (length key) 1) + keymap)) ((and (keymapp cmd) (not norecurse)) - (lookup-key-internal cmd (cdr key) accept-default theme norecurse)) + (lookup-key-internal cmd (cdr key) accept-default theme norecurse return-kmap check-parents)) (t cmd)) ;; check parent for binding - (when (keymap-parent keymap) - (lookup-key-internal (keymap-parent keymap) key nil theme norecurse)) + (when (and check-parents (keymap-parent keymap)) + (lookup-key-internal (keymap-parent keymap) key nil theme norecurse return-kmap check-parents)) (when accept-default (and map (gethash t map)))))) @@ -159,7 +212,7 @@ usable as a general function for probing keymaps. However, if the third optional argument ACCEPT-DEFAULT is non-nil, `lookup-key' will recognize the default bindings, just as `read-key-sequence' does." (check-type keymap keymap) - (lookup-key-internal keymap key accept-default theme nil)) + (lookup-key-internal keymap key accept-default theme nil nil t)) (depricate set-keymap-parent (setf keymap-parent)) (defun set-keymap-parent (keymap parent) @@ -187,12 +240,19 @@ grandparent's bindings are also included and so on." (when (keymap-parent keymap) (map-keymap function (keymap-parent keymap) theme)))) +(defvar *esc-map* (make-sparse-keymap) + "Default keymap for ESC (meta) commands. +The normal global definition of the character ESC indirects to this keymap.") + (defvar *global-map* (make-sparse-keymap) "The top level global keymap.") (defvar *ctl-x-4-map* (make-sparse-keymap) "The C-x 4 keymap.") +(defvar *ctl-x-5-map* (make-sparse-keymap) + "The C-x 4 keymap.") + (defvar *ctl-x-map* (make-sparse-keymap) "The C-x keymap.") @@ -202,119 +262,45 @@ grandparent's bindings are also included and so on." (defvar *ctl-h-map* (make-sparse-keymap) "The C-h keymap.") +(defvar *function-key-map* (make-sparse-keymap) + "Keymap that translates key sequences to key sequences during input. +This is used mainly for mapping ASCII function key sequences into +real Emacs function key events (symbols). + +The `read-key-sequence' function replaces any subsequence bound by +`function-key-map' with its binding. More precisely, when the active +keymaps have no binding for the current key sequence but +`function-key-map' binds a suffix of the sequence to a vector or string, +`read-key-sequence' replaces the matching suffix with its binding, and +continues with the new sequence. + +If the binding is a function, it is called with one argument (the prompt) +and its return value (a key sequence) is used. + +The events that come from bindings in `function-key-map' are not +themselves looked up in `function-key-map'. + +For example, suppose `function-key-map' binds `ESC O P' to [f1]. +Typing `ESC O P' to `read-key-sequence' would return [f1]. Typing +`C-x ESC O P' would return [?\\C-x f1]. If [f1] were a prefix +key, typing `ESC O P x' would return [f1 x].") + (defvar *current-global-map* *global-map*) (defvar *current-kmap* nil "The key map that the next key event will use to find a corresponding command.") -(defun make-ctrl-h-map () - (let ((kmap (make-sparse-keymap))) - (define-key kmap (make-key :char #\f) 'describe-symbol) - kmap)) - -(defun make-ctrl-x-4-map () - (let ((kmap (make-sparse-keymap))) - (define-key kmap (make-key :char #\b) 'switch-to-buffer-other-window) - kmap)) - -(defun make-ctrl-x-map (ctl-x-4-map) - (let ((kmap (make-sparse-keymap))) - (define-key kmap (make-key :char #\e :control t) 'eval-last-sexp) - (define-key kmap (make-key :char #\b) 'switch-to-buffer) - (define-key kmap (make-key :char #\c :control t) 'save-buffers-kill-emacs) - (define-key kmap (make-key :char #\f :control t) 'find-file) - (define-key kmap (make-key :char #\s :control t) 'save-buffer) - (define-key kmap (make-key :char #\k) 'kill-buffer) - (define-key kmap (make-key :char #\o) 'other-window) - (define-key kmap (make-key :char #\1) 'delete-other-windows) - (define-key kmap (make-key :char #\2) 'split-window-vertically) - (define-key kmap (make-key :char #\3) 'split-window-horizontally) - (define-key kmap (make-key :char #\x :control t) 'exchange-point-and-mark) - (define-key kmap (make-key :char #\t :control t) 'transpose-lines) - (define-key kmap (make-key :char #\4) ctl-x-4-map) - kmap)) - -(defun make-ctrl-c-map () - (let ((kmap (make-sparse-keymap))) - kmap)) - -(defun make-global-map (ctl-x-prefix ctl-c-prefix ctl-h-prefix) - "Generate self-insert commands for all printable characters. And -more." - (let ((kmap (make-sparse-keymap))) - (loop for i in '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 - #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j - #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t - #\u #\v #\w #\x #\y #\z - #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J - #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T - #\U #\V #\W #\X #\Y #\Z - #\Space #\! #\" #\# #\$ #\% #\& #\' #\( - #\) #\* #\+ #\, #\- #\. #\/ #\: #\; #\< - #\= #\> #\? #\@ #\[ #\\ #\] #\^ #\_ #\` - #\| #\} #\~ #\{) - do (define-key kmap (make-key :char i) 'self-insert-command)) - (define-key kmap (make-key :char #\Return) 'newline) - (define-key kmap (make-key :char #\Newline) 'newline) - (define-key kmap (make-key :char #\o :control t) 'open-line) - (define-key kmap (make-key :char #\j :control t) 'newline) - (define-key kmap (make-key :char #\m :control t) 'newline) - (define-key kmap (make-key :char #\f :control t) 'forward-char) - (define-key kmap (make-key :char #\f :meta t) 'forward-word) - (define-key kmap (make-key :char #\f :control t :meta t) 'forward-sexp) - (define-key kmap (make-key :char #\b :control t :meta t) 'backward-sexp) - (define-key kmap (make-key :char #\n :control t) 'next-line) - (define-key kmap (make-key :char #\p :control t) 'previous-line) - (define-key kmap (make-key :char #\b :control t) 'backward-char) - (define-key kmap (make-key :char #\b :meta t) 'backward-word) - (define-key kmap (make-key :char #\d :control t) 'delete-char) - (define-key kmap (make-key :char #\d :meta t) 'kill-word) - (define-key kmap (make-key :char #\Rubout :meta t) 'backward-kill-word) - (define-key kmap (make-key :char #\Rubout) 'delete-backward-char) - (define-key kmap (make-key :char #\Delete) 'delete-backward-char) - (define-key kmap (make-key :char #\t :meta t) 'transpose-words) - (define-key kmap (make-key :char #\t :control t) 'transpose-chars) - ;;(define-key kmap (make-key :char #\h :control t) 'delete-backward-char) - (define-key kmap (make-key :char #\u :control t) 'universal-argument) - (define-key kmap (make-key :char #\a :control t) 'beginning-of-line) - (define-key kmap (make-key :char #\e :control t) 'end-of-line) - (define-key kmap (make-key :char #\g :control t) 'keyboard-quit) - (define-key kmap (make-key :char #\v :control t) 'scroll-up) - (define-key kmap (make-key :char #\v :meta t) 'scroll-down) - (define-key kmap (make-key :char #\k :control t) 'kill-line) - (define-key kmap (make-key :char #\w :control t) 'kill-region) - (define-key kmap (make-key :char #\y :control t) 'yank) - (define-key kmap (make-key :char #\y :meta t) 'yank-pop) - (define-key kmap (make-key :char #\w :meta t) 'kill-ring-save) - (define-key kmap (make-key :char #\> :meta t) 'end-of-buffer) - (define-key kmap (make-key :char #\< :meta t) 'beginning-of-buffer) - (define-key kmap (make-key :char #\x :meta t) 'execute-extended-command) - (define-key kmap (make-key :char #\: :meta t) 'eval-expression) - (define-key kmap (make-key :char #\Space :control t) 'set-mark-command) - (define-key kmap (make-key :char #\` :control t) 'set-mark-command) - (define-key kmap (make-key :char #\! :meta t) 'shell-command) - (define-key kmap (make-key :char #\Space :meta t) 'just-one-space) - (define-key kmap (make-key :char #\\ :control t :meta t) 'indent-region) - (define-key kmap (make-key :char #\a :control t :meta t) 'beginning-of-defun) - (define-key kmap (make-key :char #\e :control t :meta t) 'end-of-defun) - (define-key kmap (make-key :char #\_ :control t) 'undo) - (define-key kmap (make-key :char #\/ :control t) 'undo) - (define-key kmap (make-key :char #\} :meta t) 'forward-paragraph) - (define-key kmap (make-key :char #\{ :meta t) 'backward-paragraph) - (define-key kmap (make-key :char #\x :control t) ctl-x-prefix) - (define-key kmap (make-key :char #\c :control t) ctl-c-prefix) - (define-key kmap (make-key :char #\h :control t) ctl-h-prefix) - kmap)) - -(defun make-global-keymaps () - "Create the default global keymaps and store them in *global-kmap -*ctl-x-map*, ..." - (setf *ctl-x-4-map* (make-ctrl-x-4-map) - *ctl-x-map* (make-ctrl-x-map *ctl-x-4-map*) - *ctl-c-map* (make-ctrl-c-map) - *ctl-h-map* (make-ctrl-h-map) - *global-map* (make-global-map *ctl-x-map* *ctl-c-map* *ctl-h-map*))) +;; initialize a skeleton structure for the keymaps +(define-key *global-map* "ESC" *esc-map*) +(define-key *esc-map* "ESC" (make-sparse-keymap)) +(define-key *global-map* "C-x" *ctl-x-map*) +(define-key *ctl-x-map* "n" (make-sparse-keymap)) +(define-key *global-map* "C-c" *ctl-c-map*) +(define-key *global-map* "C-h" *ctl-h-map*) +(define-key *ctl-x-map* "r" (make-sparse-keymap)) +(define-key *ctl-x-map* "a" (make-sparse-keymap)) +(define-key *ctl-x-map* "a i" (make-sparse-keymap)) (defun copy-keymap (keymap) (declare (ignore keymap)) @@ -390,3 +376,129 @@ not be in the future." (defun apropos-internal () (error "unimplemented")) +;; This is a struct to make it easier to add new elements to, should +;; we want to. Also, it makes code easier to read, I think. +(defstruct minor-mode-map + variable keymap) + +(defvar *minor-mode-map-list* nil + "Alist of keymaps to use for minor modes. +Each element looks like (VARIABLE . KEYMAP); KEYMAP is used to read +key sequences and look up bindings iff VARIABLE's value is non-nil. +If two active keymaps bind the same key, the keymap appearing earlier +in the list takes precedence.") + +(define-buffer-local *minor-mode-overriding-map-list* nil + "Alist of keymaps to use for minor modes, in current major mode. +This variable is an alist just like `*minor-mode-map-list*', and it is +used the same way (and before `*minor-mode-map-list*'); however, +it is provided for major modes to bind locally.") + + +;; (defun make-ctrl-h-map () +;; (let ((kmap (make-sparse-keymap))) +;; (define-key kmap (make-key :char #\f) 'describe-symbol) +;; kmap)) + +;; (defun make-ctrl-x-4-map () +;; (let ((kmap (make-sparse-keymap))) +;; (define-key kmap (make-key :char #\b) 'switch-to-buffer-other-window) +;; kmap)) + +;; (defun make-ctrl-x-map (ctl-x-4-map) +;; (let ((kmap (make-sparse-keymap))) +;; (define-key kmap (make-key :char #\e :control t) 'eval-last-sexp) +;; (define-key kmap (make-key :char #\b) 'switch-to-buffer) +;; (define-key kmap (make-key :char #\c :control t) 'save-buffers-kill-emacs) +;; (define-key kmap (make-key :char #\f :control t) 'find-file) +;; (define-key kmap (make-key :char #\s :control t) 'save-buffer) +;; (define-key kmap (make-key :char #\k) 'kill-buffer) +;; (define-key kmap (make-key :char #\o) 'other-window) +;; (define-key kmap (make-key :char #\1) 'delete-other-windows) +;; (define-key kmap (make-key :char #\2) 'split-window-vertically) +;; (define-key kmap (make-key :char #\3) 'split-window-horizontally) +;; (define-key kmap (make-key :char #\x :control t) 'exchange-point-and-mark) +;; (define-key kmap (make-key :char #\t :control t) 'transpose-lines) +;; (define-key kmap (make-key :char #\4) ctl-x-4-map) +;; kmap)) + +;; (defun make-ctrl-c-map () +;; (let ((kmap (make-sparse-keymap))) +;; kmap)) + +;; (defun make-global-map (ctl-x-prefix ctl-c-prefix ctl-h-prefix) +;; "Generate self-insert commands for all printable characters. And +;; more." +;; (let ((kmap (make-sparse-keymap))) +;; (loop for i in '(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9 +;; #\a #\b #\c #\d #\e #\f #\g #\h #\i #\j +;; #\k #\l #\m #\n #\o #\p #\q #\r #\s #\t +;; #\u #\v #\w #\x #\y #\z +;; #\A #\B #\C #\D #\E #\F #\G #\H #\I #\J +;; #\K #\L #\M #\N #\O #\P #\Q #\R #\S #\T +;; #\U #\V #\W #\X #\Y #\Z +;; #\Space #\! #\" #\# #\$ #\% #\& #\' #\( +;; #\) #\* #\+ #\, #\- #\. #\/ #\: #\; #\< +;; #\= #\> #\? #\@ #\[ #\\ #\] #\^ #\_ #\` +;; #\| #\} #\~ #\{) +;; do (define-key kmap (make-key :char i) 'self-insert-command)) +;; (define-key kmap (make-key :char #\Return) 'newline) +;; (define-key kmap (make-key :char #\Newline) 'newline) +;; (define-key kmap (make-key :char #\o :control t) 'open-line) +;; (define-key kmap (make-key :char #\j :control t) 'newline) +;; (define-key kmap (make-key :char #\m :control t) 'newline) +;; (define-key kmap (make-key :char #\f :control t) 'forward-char) +;; (define-key kmap (make-key :char #\f :meta t) 'forward-word) +;; (define-key kmap (make-key :char #\f :control t :meta t) 'forward-sexp) +;; (define-key kmap (make-key :char #\b :control t :meta t) 'backward-sexp) +;; (define-key kmap (make-key :char #\n :control t) 'next-line) +;; (define-key kmap (make-key :char #\p :control t) 'previous-line) +;; (define-key kmap (make-key :char #\b :control t) 'backward-char) +;; (define-key kmap (make-key :char #\b :meta t) 'backward-word) +;; (define-key kmap (make-key :char #\d :control t) 'delete-char) +;; (define-key kmap (make-key :char #\d :meta t) 'kill-word) +;; (define-key kmap (make-key :char #\Rubout :meta t) 'backward-kill-word) +;; (define-key kmap (make-key :char #\Rubout) 'delete-backward-char) +;; (define-key kmap (make-key :char #\Delete) 'delete-backward-char) +;; (define-key kmap (make-key :char #\t :meta t) 'transpose-words) +;; (define-key kmap (make-key :char #\t :control t) 'transpose-chars) +;; ;;(define-key kmap (make-key :char #\h :control t) 'delete-backward-char) +;; (define-key kmap (make-key :char #\u :control t) 'universal-argument) +;; (define-key kmap (make-key :char #\a :control t) 'beginning-of-line) +;; (define-key kmap (make-key :char #\e :control t) 'end-of-line) +;; (define-key kmap (make-key :char #\g :control t) 'keyboard-quit) +;; (define-key kmap (make-key :char #\v :control t) 'scroll-up) +;; (define-key kmap (make-key :char #\v :meta t) 'scroll-down) +;; (define-key kmap (make-key :char #\k :control t) 'kill-line) +;; (define-key kmap (make-key :char #\w :control t) 'kill-region) +;; (define-key kmap (make-key :char #\y :control t) 'yank) +;; (define-key kmap (make-key :char #\y :meta t) 'yank-pop) +;; (define-key kmap (make-key :char #\w :meta t) 'kill-ring-save) +;; (define-key kmap (make-key :char #\> :meta t) 'end-of-buffer) +;; (define-key kmap (make-key :char #\< :meta t) 'beginning-of-buffer) +;; (define-key kmap (make-key :char #\x :meta t) 'execute-extended-command) +;; (define-key kmap (make-key :char #\: :meta t) 'eval-expression) +;; (define-key kmap (make-key :char #\Space :control t) 'set-mark-command) +;; (define-key kmap (make-key :char #\` :control t) 'set-mark-command) +;; (define-key kmap (make-key :char #\! :meta t) 'shell-command) +;; (define-key kmap (make-key :char #\Space :meta t) 'just-one-space) +;; (define-key kmap (make-key :char #\\ :control t :meta t) 'indent-region) +;; (define-key kmap (make-key :char #\a :control t :meta t) 'beginning-of-defun) +;; (define-key kmap (make-key :char #\e :control t :meta t) 'end-of-defun) +;; (define-key kmap (make-key :char #\_ :control t) 'undo) +;; (define-key kmap (make-key :char #\/ :control t) 'undo) +;; (define-key kmap (make-key :char #\} :meta t) 'forward-paragraph) +;; (define-key kmap (make-key :char #\{ :meta t) 'backward-paragraph) +;; (define-key kmap (make-key :char #\x :control t) ctl-x-prefix) +;; (define-key kmap (make-key :char #\c :control t) ctl-c-prefix) +;; (define-key kmap (make-key :char #\h :control t) ctl-h-prefix) +;; kmap)) + +;; (defun make-global-keymaps () +;; "Create the default global keymaps and store them in *global-kmap +;; *ctl-x-map*, ..." +;; (setf *ctl-x-4-map* (make-ctrl-x-4-map) +;; *ctl-x-map* (make-ctrl-x-map *ctl-x-4-map*) +;; *ctl-c-map* (make-ctrl-c-map) +;; *ctl-h-map* (make-ctrl-h-map) +;; *global-map* (make-global-map *ctl-x-map* *ctl-c-map* *ctl-h-map*))) diff --git a/src/lice.asd b/src/lice.asd dissimilarity index 77% index 4399cb9..b5cf48b 100644 --- a/src/lice.asd +++ b/src/lice.asd @@ -1,63 +1,77 @@ -;; -*- lisp -*- - -(defpackage :lice-system (:use :cl :asdf)) -(in-package :lice-system) - -(load "package.lisp") - -(defsystem :lice - :depends-on (#-clisp cl-ncurses cl-ppcre #+sbcl sb-posix) - :components ((:file "wrappers") - (:file "elisp") - (:file "global") - (:file "custom") - (:file "commands") - (:file "data-types") - (:file "charset") - (:file "keymap" :depends-on ("global")) - (:file "casefiddle") - (:file "subprocesses" :depends-on ("wrappers" "commands")) - (:file "buffer-local" :depends-on ("data-types")) - (:file "buffer" :depends-on ("data-types" "buffer-local" "commands" "wrappers" "global")) - (:file "intervals" :depends-on ("data-types")) - (:file "textprop" :depends-on ("intervals" "global")) - (:file "search" :depends-on ("buffer")) - (:file "frame" :depends-on ("data-types")) - (:file "window" :depends-on ("buffer" "search" "commands" "frame" "data-types")) - (:file "render" :depends-on ("frame" "window")) - (:file "wm" :depends-on ("data-types" "window" "frame")) - - ;; from this point on there are warnings because of two-way dependencies - (:file "insdel" :depends-on ("intervals" #|"undo"|# "buffer")) - (:file "cmds" :depends-on ("keymap" "insdel")) - (:file "editfns" :depends-on ("buffer" "insdel" "textprop" "cmds")) - (:file "undo" :depends-on ("commands" "window")) - (:file "syntax" :depends-on ("buffer")) - (:file "major-mode" :depends-on ("keymap" "syntax")) - (:file "keyboard" :depends-on ("commands" "keymap" "subprocesses" "render")) - (:file "debugger" :depends-on ("commands" "major-mode")) - (:file "recursive-edit" :depends-on ("keyboard" "render" "debugger")) - (:file "minibuffer" :depends-on ("buffer" "window" "recursive-edit" "wm")) - (:file "files" :depends-on ("buffer" "buffer-local" "commands" "custom")) - (:file "help" :depends-on ("buffer" "commands")) - (:file "debug" :depends-on ("buffer" "commands")) - #+sbcl (:file "tty-render" :depends-on ("buffer" "window" "frame" "render")) - #+clisp (:file "clisp-render" :depends-on ("buffer" "window" "frame" "render")) - (:file "main" :depends-on ("buffer" "major-mode" "elisp" #+sbcl "tty-render" #+clisp "clisp-render")) - (:file "indent" :depends-on (#|"subr"|#)) - - (:module lisp - :components ((:file "subr") - (:file "simple" :depends-on ("subr" #|"textmodes/fill"|#)) - (:file "lisp-mode" :depends-on (#|"indent"|# "simple")) - (:file "lisp-indent" :depends-on ("lisp-mode" #|"indent"|# "simple")) - (:file "paragraphs" :depends-on ("simple")))) - - (:module textmodes - :components (;; (:file "fill" :depends-on ()) ; this one is too advanced for now - (:file "text-mode" :depends-on ()))) - - (:module play - :components ((:file "dissociate" :depends-on nil) - (:file "hanoi") - (:file "doctor" :depends-on (#|"simple" "paragraphs" text-mode"|#)))))) +;; -*- lisp -*- + +(defpackage :lice-system (:use :cl :asdf)) +(in-package :lice-system) + +(defsystem :lice + :depends-on (#-clisp cl-ncurses cl-ppcre #+sbcl sb-posix) + :serial t + :components ((:file "package") + (:file "wrappers") + (:file "emacs") + (:file "callproc") + (:file "elisp") + (:file "global") + (:file "fns") + (:file "data") + (:file "custom") + (:file "commands") + (:file "dired") + (:file "data-types") + (:file "charset") + (:file "subprocesses") + (:file "buffer-local") + (:file "keymap") + (:file "casefiddle") + (:file "buffer") + (:file "intervals") + (:file "textprop") + (:file "search") + (:file "frame") + (:file "window") + (:file "render") + (:file "wm") + + ;; from this point on there are warnings because of two-way dependencies + (:file "insdel") + (:file "cmds") + (:file "editfns") + (:file "undo") + (:file "syntax") + (:file "major-mode") + (:file "keyboard") + (:file "debugger") + (:file "recursive-edit") + (:file "minibuffer") + (:file "files") + (:file "help") + (:file "debug") + #+sbcl (:file "tty-render") + #+clisp (:file "clisp-render") + (:file "indent") + + (:module lisp + :serial t + :components ((:file "subr") + (:file "simple") + (:file "lisp-mode") + (:file "lisp-indent") + (:file "paragraphs") + (:file "bindings"))) + + (:module emacs-lisp + :serial t + :components ((:file "easy-mmode"))) + + (:module textmodes + :serial t + :components (;; (:file "fill" :depends-on ()) ; this one is too advanced for now + (:file "text-mode"))) + + (:module play + :serial t + :components ((:file "dissociate") + (:file "hanoi") + (:file "doctor"))) + + (:file "main"))) diff --git a/src/lisp/bindings.lisp b/src/lisp/bindings.lisp new file mode 100644 index 0000000..8f3df89 --- /dev/null +++ b/src/lisp/bindings.lisp @@ -0,0 +1,1082 @@ +;;; bindings.el --- define standard key bindings and some variables + +;; Copyright (C) 1985, 1986, 1987, 1992, 1993, 1994, 1995, 1996, 1999, +;; 2000, 2001, 2002, 2003, 2004, 2005, 2006 Free Software Foundation, Inc. + +;; Maintainer: FSF +;; Keywords: internal + +;; This file is part of GNU Emacs. + +;; GNU Emacs 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, Inc., 51 Franklin Street, Fifth Floor, +;; Boston, MA 02110-1301, USA. + +;;; Commentary: + +;;; !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! +;;; Special formatting conventions are used in this file! +;;; +;;; A backslash-newline is used at the beginning of a documentation string +;;; when that string should be stored in the file etc/DOCnnn, not in core. +;;; +;;; Such strings read into Lisp as numbers (during the pure-loading phase). +;;; +;;; But you must obey certain rules to make sure the string is understood +;;; and goes into etc/DOCnnn properly. +;;; +;;; The doc string must appear in the standard place in a call to +;;; defun, autoload, defvar or defconst. No Lisp macros are recognized. +;;; The open-paren starting the definition must appear in column 0. +;;; +;;; In defvar and defconst, there is an additional rule: +;;; The double-quote that starts the string must be on the same +;;; line as the defvar or defconst. +;;; !!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!!! + +;;; Code: + +(in-package "LICE") + +(defun make-mode-line-mouse-map (mouse function) "\ +Return a keymap with single entry for mouse key MOUSE on the mode line. +MOUSE is defined to run function FUNCTION with no args in the buffer +corresponding to the mode line clicked." + (let ((map (make-sparse-keymap))) + (define-key map (vector 'mode-line mouse) function) + map)) + + +(defcommand mode-line-toggle-read-only ((event) + :event) + "Like `toggle-read-only', for the mode-line." + ;;(interactive "e") + (save-selected-window + (select-window (posn-window (event-start event))) + (toggle-read-only) + (force-mode-line-update))) + + +(defcommand mode-line-toggle-modified ((event) + :event) + "Toggle the buffer-modified flag from the mode-line." + ;;(interactive "e") + (save-selected-window + (select-window (posn-window (event-start event))) + (set-buffer-modified-p (not (buffer-modified-p))) + (force-mode-line-update))) + + +(defcommand mode-line-widen ((event) + :event) + "Widen a buffer from the mode-line." + (save-selected-window + (select-window (posn-window (event-start event))) + (widen) + (force-mode-line-update))) + + +(defcommand mode-line-abbrev-mode ((event) + :event) + "Turn off `abbrev-mode' from the mode-line." + ;;(interactive "e") + (save-selected-window + (select-window (posn-window (event-start event))) + (abbrev-mode) + (force-mode-line-update))) + + +(defcommand mode-line-auto-fill-mode ((event) + :event) + "Turn off `auto-fill-mode' from the mode-line." + ;;(interactive "e") + (save-selected-window + (select-window (posn-window (event-start event))) + (auto-fill-mode) + (force-mode-line-update))) + +;; FIXME: when we figure out charsets and stuff, maybe uncomment this -sabetts +;; FIXME: interactive lambdas are impossible in LICE +;; (defvar mode-line-input-method-map +;; (let ((map (make-sparse-keymap))) +;; (define-key map (make-click :where :mode-line :button :mouse-2) +;; (lambda (e) +;; (interactive "e") +;; (save-selected-window +;; (select-window +;; (posn-window (event-start e))) +;; (toggle-input-method) +;; (force-mode-line-update)))) +;; (define-key map (make-click :where :mode-line :button :mouse-3) +;; (lambda (e) +;; (interactive "e") +;; (save-selected-window +;; (select-window +;; (posn-window (event-start e))) +;; (describe-current-input-method)))) +;; (purecopy map))) +;; +;; ;; FIXME: interactive lambdas are impossible in LICE +;; (defvar mode-line-coding-system-map +;; (let ((map (make-sparse-keymap))) +;; (define-key map (make-click :where :mode-line :button :mouse-1) +;; (lambda (e) +;; (interactive "e") +;; (save-selected-window +;; (select-window (posn-window (event-start e))) +;; (when (and enable-multibyte-characters +;; buffer-file-coding-system) +;; (describe-coding-system buffer-file-coding-system))))) +;; (purecopy map)) +;; "Local keymap for the coding-system part of the mode line.") +;; +;; +;; (defcommand mode-line-change-eol ((event) +;; :event) +;; "Cycle through the various possible kinds of end-of-line styles." +;; ;;(interactive "e") +;; (save-selected-window +;; (select-window (posn-window (event-start event))) +;; (let ((eol (coding-system-eol-type buffer-file-coding-system))) +;; (set-buffer-file-coding-system +;; (cond ((eq eol 0) 'dos) ((eq eol 1) 'mac) (t 'unix)))))) +;; +;; (defvar mode-line-eol-desc-cache nil) +;; +;; (defun mode-line-eol-desc () +;; (let* ((eol (coding-system-eol-type buffer-file-coding-system)) +;; (mnemonic (coding-system-eol-type-mnemonic buffer-file-coding-system)) +;; (desc (assq eol mode-line-eol-desc-cache))) +;; (el:if (and desc (eq (cadr desc) mnemonic)) +;; (cddr desc) +;; (if desc (setq mode-line-eol-desc-cache nil)) ;Flush the cache if stale. +;; (setq desc +;; (propertize +;; mnemonic +;; 'help-echo (format nil "~a end-of-line; mouse-1 to cycle" +;; (if (eq eol 0) "Unix-style LF" +;; (if (eq eol 1) "Dos-style CRLF" +;; (if (eq eol 2) "Mac-style CR" +;; "Undecided")))) +;; 'keymap +;; ;;(eval-when-compile +;; #.(let ((map (make-sparse-keymap))) +;; (define-key map [mode-line mouse-1] 'mode-line-change-eol) +;; map) +;; 'mouse-face 'mode-line-highlight)) +;; (push (cons eol (cons mnemonic desc)) mode-line-eol-desc-cache) +;; desc))) +;; +;; (defvar mode-line-mule-info +;; `("" +;; (current-input-method +;; (:propertize ("" current-input-method-title) +;; help-echo (concat +;; "Input method: " +;; current-input-method +;; ". mouse-2: disable, mouse-3: describe") +;; local-map ,mode-line-input-method-map +;; mouse-face mode-line-highlight)) +;; ,(propertize +;; "%z" +;; 'help-echo +;; #'(lambda (window object point) +;; (with-current-buffer (window-buffer window) +;; ;; Don't show this tip if the coding system is nil, +;; ;; it reads like a bug, and is not useful anyway. +;; (when buffer-file-coding-system +;; (if enable-multibyte-characters +;; (concat (symbol-name buffer-file-coding-system) +;; " buffer; mouse-1: describe coding system") +;; (concat "Unibyte " (symbol-name buffer-file-coding-system) +;; " buffer"))))) +;; 'mouse-face 'mode-line-highlight +;; 'local-map mode-line-coding-system-map) +;; (:eval (mode-line-eol-desc))) +;; "Mode-line control for displaying information of multilingual environment. +;; Normally it displays current input method (if any activated) and +;; mnemonics of the following coding systems: +;; coding system for saving or writing the current buffer +;; coding system for keyboard input (if Emacs is running on terminal) +;; coding system for terminal output (if Emacs is running on terminal)" +;; ;; Currently not: +;; ;; coding system for decoding output of buffer process (if any) +;; ;; coding system for encoding text to send to buffer process (if any)." +;; ) +;; +;; (make-variable-buffer-local 'mode-line-mule-info) + +(defvar mode-line-frame-identification '("-%F ") + "Mode-line control to describe the current frame.") + +(define-buffer-local mode-line-process nil "\ +Mode-line control for displaying info on process status. +Normally nil in most modes, since there is no process to display.") + +(make-variable-buffer-local 'mode-line-process) + +(define-buffer-local mode-line-modified + (list (propertize + "%1*" + 'help-echo (purecopy (lambda (window object point) + (format nil "~sead-only: mouse-1 toggles" + (save-selected-window + (select-window window) + (if (buffer-read-only) + "R" + "Not r"))))) + 'local-map (purecopy (make-mode-line-mouse-map + 'mouse-1 + #'mode-line-toggle-read-only)) + 'mouse-face 'mode-line-highlight) + (propertize + "%1+" + 'help-echo (purecopy (lambda (window object point) + (format nil "~sodified: mouse-1 toggles" + (save-selected-window + (select-window window) + (if (buffer-modified-p) + "M" + "Not m"))))) + 'local-map (purecopy (make-mode-line-mouse-map + 'mouse-1 #'mode-line-toggle-modified)) + 'mouse-face 'mode-line-highlight)) + "Mode-line control for displaying whether current buffer is modified.") + +(make-variable-buffer-local 'mode-line-modified) + +;; Actual initialization is below. +(defvar mode-line-position nil + "Mode-line control for displaying the position in the buffer. +Normally displays the buffer percentage and, optionally, the +buffer size, the line number and the column number.") + +(defvar mode-line-modes nil + "Mode-line control for displaying major and minor modes.") + +(defvar mode-line-major-mode-keymap + (let ((map (make-sparse-keymap))) + (define-key map (make-click :where :mode-line :button :down-mouse-1) 'mouse-major-mode-menu) + (define-key map (make-click :where :mode-line :button :mouse-2) 'describe-mode) + (define-key map (make-click :where :mode-line :button :down-mouse-3) 'mode-line-mode-menu-1) + map) "\ +Keymap to display on major mode.") + +(defvar mode-line-minor-mode-keymap + (let ((map (make-sparse-keymap))) + (define-key map (make-click :where :mode-line :button :mouse-2) 'mode-line-minor-mode-help) + (define-key map (make-click :where :mode-line :button :down-mouse-3) 'mode-line-mode-menu-1) + (define-key map (make-click :where :header-line :button :down-mouse-3) 'mode-line-mode-menu-1) + map) "\ +Keymap to display on minor modes.") + +;; FIXME: When our modeline formatting is up to snuff, uncomment -sabetts +;; (let* ((help-echo +;; ;; The multi-line message doesn't work terribly well on the +;; ;; bottom mode line... Better ideas? +;; ;; "\ +;; ;; mouse-1: select window, mouse-2: delete others, mouse-3: delete, +;; ;; drag-mouse-1: resize, C-mouse-2: split horizontally" +;; "mouse-1: select (drag to resize), mouse-2: delete others, mouse-3: delete this") +;; (dashes (propertize "--" 'help-echo help-echo)) +;; (standard-mode-line-format +;; (list +;; "%e" +;; (propertize "-" 'help-echo help-echo) +;; 'mode-line-mule-info +;; 'mode-line-modified +;; 'mode-line-frame-identification +;; 'mode-line-buffer-identification +;; (propertize " " 'help-echo help-echo) +;; 'mode-line-position +;; '(vc-mode vc-mode) +;; (propertize " " 'help-echo help-echo) +;; 'mode-line-modes +;; `(which-func-mode ("" which-func-format ,dashes)) +;; `(global-mode-string (,dashes global-mode-string)) +;; (propertize "-%-" 'help-echo help-echo))) +;; (standard-mode-line-modes +;; (list +;; (propertize "%[(" 'help-echo help-echo) +;; `(:propertize ("" mode-name) +;; help-echo "mouse-1: major mode, mouse-2: major mode help, mouse-3: toggle minor modes" +;; mouse-face mode-line-highlight +;; local-map ,mode-line-major-mode-keymap) +;; '("" mode-line-process) +;; `(:propertize ("" minor-mode-alist) +;; mouse-face mode-line-highlight +;; help-echo "mouse-2: minor mode help, mouse-3: toggle minor modes" +;; local-map ,mode-line-minor-mode-keymap) +;; (propertize "%n" 'help-echo "mouse-2: widen" +;; 'mouse-face 'mode-line-highlight +;; 'local-map (make-mode-line-mouse-map +;; 'mouse-2 #'mode-line-widen)) +;; (propertize ")%]--" 'help-echo help-echo))) +;; (standard-mode-line-position +;; `((-3 ,(propertize "%p" 'help-echo help-echo)) +;; (size-indication-mode +;; (8 ,(propertize " of %I" 'help-echo help-echo))) +;; (line-number-mode +;; ((column-number-mode +;; (10 ,(propertize " (%l,%c)" 'help-echo help-echo)) +;; (6 ,(propertize " L%l" 'help-echo help-echo)))) +;; ((column-number-mode +;; (5 ,(propertize " C%c" 'help-echo help-echo)))))))) +;; +;; (setq-default *mode-line-format* standard-mode-line-format) +;; (setf (get '*mode-line-format* 'standard-value) +;; (list `(quote ,standard-mode-line-format))) +;; +;; (setq-default mode-line-modes standard-mode-line-modes) +;; (setf (get 'mode-line-modes 'standard-value) +;; (list `(quote ,standard-mode-line-modes))) +;; +;; (setq-default mode-line-position standard-mode-line-position) +;; (setf (get 'mode-line-position 'standard-value) +;; (list `(quote ,standard-mode-line-position)))) + +(defvar mode-line-buffer-identification-keymap nil "\ +Keymap for what is displayed by `mode-line-buffer-identification'.") + +;; Add menu of buffer operations to the buffer identification part +;; of the mode line.or header line. +; +(let ((map (make-sparse-keymap))) + ;; Bind down- events so that the global keymap won't ``shine + ;; through''. + (define-key map (make-click :where :mode-line :button :mouse-1) 'mode-line-previous-buffer) + (define-key map (make-click :where :header-line :button :down-mouse-1) 'ignore) + (define-key map (make-click :where :header-line :button :mouse-1) 'mode-line-previous-buffer) + (define-key map (make-click :where :header-line :button :down-mouse-3) 'ignore) + (define-key map (make-click :where :mode-line :button :mouse-3) 'mode-line-next-buffer) + (define-key map (make-click :where :header-line :button :down-mouse-3) 'ignore) + (define-key map (make-click :where :header-line :button :mouse-3) 'mode-line-next-buffer) + (setq mode-line-buffer-identification-keymap map)) + +(defun propertized-buffer-identification (fmt) + "Return a list suitable for `mode-line-buffer-identification'. +FMT is a format specifier such as \"%12b\". This function adds +text properties for face, help-echo, and local-map to it." + (list (propertize fmt + 'face 'mode-line-buffer-id + 'help-echo + (purecopy "mouse-1: previous buffer, mouse-3: next buffer") + 'mouse-face 'mode-line-highlight + 'local-map mode-line-buffer-identification-keymap))) + +(define-buffer-local mode-line-buffer-identification (propertized-buffer-identification "%12b") "\ +Mode-line control for identifying the buffer being displayed. +Its default value is (\"%12b\") with some text properties added. +Major modes that edit things other than ordinary files may change this +\(e.g. Info, Dired,...)") + +(make-variable-buffer-local 'mode-line-buffer-identification) + +(defcommand unbury-buffer () "\ +Switch to the last buffer in the buffer list." + (switch-to-buffer (last-buffer))) + +(defcommand mode-line-unbury-buffer ((event) + :event) "\ +Call `unbury-buffer' in this window." + (save-selected-window + (select-window (posn-window (event-start event))) + (unbury-buffer))) + +(defcommand mode-line-bury-buffer ((event) + :event)"\ +Like `bury-buffer', but temporarily select EVENT's window." + (save-selected-window + (select-window (posn-window (event-start event))) + (bury-buffer))) + +(defcommand mode-line-other-buffer () "\ +Switch to the most recently selected buffer other than the current one." + (switch-to-buffer (other-buffer))) + +(defcommand mode-line-next-buffer ((event) + :event) + "Like `next-buffer', but temporarily select EVENT's window." + (save-selected-window + (select-window (posn-window (event-start event))) + (next-buffer))) + +(defcommand mode-line-previous-buffer ((event) + :event) + "Like `previous-buffer', but temporarily select EVENT's window." + (save-selected-window + (select-window (posn-window (event-start event))) + (previous-buffer))) + +(defvar mode-line-mode-menu (make-sparse-keymap "Minor Modes") "\ +Menu of mode operations in the mode line.") + +(defcommand mode-line-mode-menu-1 ((event) + :event) + (save-selected-window + (select-window (posn-window (event-start event))) + (let* ((selection (mode-line-mode-menu event)) + (binding (and selection (lookup-key mode-line-mode-menu + (vector (car selection)))))) + (if binding + (call-interactively binding))))) + +(defmacro bound-and-true-p (var) + "Return the value of symbol VAR if it is bound, else nil." + `(and (boundp (quote ,var)) ,var)) + +;; FIXME: when menu stuff is added uncomment this +;; (define-key mode-line-mode-menu [overwrite-mode] +;; `(menu-item ,(purecopy "Overwrite (Ovwrt)") overwrite-mode +;; :button (:toggle . overwrite-mode))) +;; (define-key mode-line-mode-menu [outline-minor-mode] +;; `(menu-item ,(purecopy "Outline (Outl)") outline-minor-mode +;; :button (:toggle . (bound-and-true-p outline-minor-mode)))) +;; (define-key mode-line-mode-menu [line-number-mode] +;; `(menu-item ,(purecopy "Line number") line-number-mode +;; :button (:toggle . line-number-mode))) +;; (define-key mode-line-mode-menu [highlight-changes-mode] +;; `(menu-item ,(purecopy "Highlight changes (Chg)") highlight-changes-mode +;; :button (:toggle . (bound-and-true-p highlight-changes-mode)))) +;; (define-key mode-line-mode-menu [hide-ifdef-mode] +;; `(menu-item ,(purecopy "Hide ifdef (Ifdef)") hide-ifdef-mode +;; :button (:toggle . (bound-and-true-p hide-ifdef-mode)))) +;; (define-key mode-line-mode-menu [glasses-mode] +;; `(menu-item ,(purecopy "Glasses (o^o)") glasses-mode +;; :button (:toggle . (bound-and-true-p glasses-mode)))) +;; (define-key mode-line-mode-menu [font-lock-mode] +;; `(menu-item ,(purecopy "Font Lock") font-lock-mode +;; :button (:toggle . font-lock-mode))) +;; (define-key mode-line-mode-menu [flyspell-mode] +;; `(menu-item ,(purecopy "Flyspell (Fly)") flyspell-mode +;; :button (:toggle . (bound-and-true-p flyspell-mode)))) +;; (define-key mode-line-mode-menu [column-number-mode] +;; `(menu-item ,(purecopy "Column number") column-number-mode +;; :button (:toggle . column-number-mode))) +;; (define-key mode-line-mode-menu [auto-revert-tail-mode] +;; `(menu-item ,(purecopy "Auto revert tail (Tail)") auto-revert-tail-mode +;; :button (:toggle . (bound-and-true-p auto-revert-tail-mode)))) +;; (define-key mode-line-mode-menu [auto-revert-mode] +;; `(menu-item ,(purecopy "Auto revert (ARev)") auto-revert-mode +;; :button (:toggle . (bound-and-true-p auto-revert-mode)))) +;; (define-key mode-line-mode-menu [auto-fill-mode] +;; `(menu-item ,(purecopy "Auto fill (Fill)") auto-fill-mode +;; :button (:toggle . auto-fill-function))) +;; (define-key mode-line-mode-menu [abbrev-mode] +;; `(menu-item ,(purecopy "Abbrev (Abbrev)") abbrev-mode +;; :button (:toggle . abbrev-mode))) + +(defun mode-line-mode-menu (event) + (interactive "@e") + (x-popup-menu event mode-line-mode-menu)) + +(defun mode-line-minor-mode-help (event) + "Describe minor mode for EVENT occured on minor modes area of the mode line." + (interactive "@e") + (let ((indicator (car (nth 4 (car (cdr event)))))) + (describe-minor-mode-from-indicator indicator))) + +(defvar minor-mode-alist nil "\ +Alist saying how to show minor modes in the mode line. +Each element looks like (VARIABLE STRING); +STRING is included in the mode line iff VARIABLE's value is non-nil. + +Actually, STRING need not be a string; any possible mode-line element +is okay. See `mode-line-format'.") +;; Don't use purecopy here--some people want to change these strings. +(setq minor-mode-alist + (list + (list 'abbrev-mode " Abbrev") + '(overwrite-mode overwrite-mode) + (list 'auto-fill-function " Fill") + ;; not really a minor mode... + '(defining-kbd-macro " Def"))) + +;; These variables are used by autoloadable packages. +;; They are defined here so that they do not get overridden +;; by the loading of those packages. + +;; Names in directory that end in one of these +;; are ignored in completion, +;; making it more likely you will get a unique match. +(setq completion-ignored-extensions + (append + (cond ((memq system-type '(ms-dos windows-nt)) + '(".o" "~" ".bin" ".bak" ".obj" ".map" ".ico" ".pif" ".lnk" + ".a" ".ln" ".blg" ".bbl" ".dll" ".drv" ".vxd" ".386")) + ((eq system-type 'vax-vms) + '(".obj" ".exe" ".bin" ".lbin" ".sbin" + ".brn" ".rnt" ".lni" + ".olb" ".tlb" ".mlb" ".hlb")) + (t + '(".o" "~" ".bin" ".lbin" ".so" + ".a" ".ln" ".blg" ".bbl"))) + '(".elc" ".lof" + ".glo" ".idx" ".lot" + ;; TeX-related + ".dvi" ".fmt" ".tfm" ".pdf" + ;; Java compiled + ".class" + ;; CLISP + ".fas" ".lib" ".mem" + ;; CMUCL + ".x86f" ".sparcf" + ;; Other CL implementations (Allegro, LispWorks, OpenMCL) + ".fasl" ".ufsl" ".fsl" ".dxl" ".pfsl" ".dfsl" + ;; Libtool + ".lo" ".la" + ;; Gettext + ".gmo" ".mo" + ;; Texinfo-related + ;; This used to contain .log, but that's commonly used for log + ;; files you do want to see, not just TeX stuff. -- fx + ".toc" ".aux" + ".cp" ".fn" ".ky" ".pg" ".tp" ".vr" + ".cps" ".fns" ".kys" ".pgs" ".tps" ".vrs" + ;; Python byte-compiled + ".pyc" ".pyo"))) + +;; Suffixes used for executables. +(setq exec-suffixes + (cond + ((memq system-type '(ms-dos windows-nt)) + '(".exe" ".com" ".bat" ".cmd" ".btm" "")) + (t + '("")))) + +;; Packages should add to this list appropriately when they are +;; loaded, rather than listing everything here. +(setq debug-ignored-errors + '(beginning-of-line beginning-of-buffer end-of-line + end-of-buffer end-of-file buffer-read-only + file-supersession + "^Previous command was not a yank$" + "^Minibuffer window is not active$" + "^No previous history search regexp$" + "^No later matching history item$" + "^No earlier matching history item$" + "^End of history; no default available$" + "^End of history; no next item$" + "^Beginning of history; no preceding item$" + "^No recursive edit is in progress$" + "^Changes to be undone are outside visible portion of buffer$" + "^No undo information in this buffer$" + "^No further undo information" + "^Save not confirmed$" + "^Recover-file cancelled\\.$" + "^Cannot switch buffers in a dedicated window$" + )) + + +(make-variable-buffer-local 'indent-tabs-mode) + +;; We have base64 and md5 functions built in now. +(provide 'base64) +(provide 'md5) +(provide 'overlay) ;;'(display syntax-table field)) +(provide 'text-properties) ;; '(display syntax-table field point-entered)) + +(define-key *esc-map* "TAB" 'complete-symbol) + +(defcommand complete-symbol ((arg) + :raw-prefix) "\ +Perform tags completion on the text around point. +Completes to the set of names listed in the current tags table. +The string to complete is chosen in the same way as the default +for \\[find-tag] (which see). + +With a prefix argument, this command does completion within +the collection of symbols listed in the index of the manual for the +language you are using." + (if arg + (info-complete-symbol) + (if (fboundp 'complete-tag) + (complete-tag) + ;; Don't autoload etags if we have no tags table. + (error (substitute-command-keys + "No tags table loaded; use \\[visit-tags-table] to load one"))))) + +;; Reduce total amount of space we must allocate during this function +;; that we will not need to keep permanently. +(garbage-collect) + +;; FIXME: figure out how cl charset stuff works and uncomment this code -sabetts +;; Make all multibyte characters self-insert. +;; (let ((l (generic-character-list)) +;; (table (nth 1 *global-map*))) +;; (while l +;; (set-char-table-default table (car l) 'self-insert-command) +;; (setq l (cdr l)))) + +(setq help-event-list '(help f1)) + +(make-variable-buffer-local '*minor-mode-overriding-map-list*) + +;; From frame.c +(global-set-key :switch-frame 'handle-switch-frame) +(global-set-key :select-window 'handle-select-window) + +;; FIXME: Do those 3 events really ever reach the *global-map* ? +;; It seems that they can't because they're handled via +;; special-event-map which is used at very low-level. -stef +(global-set-key :delete-frame 'handle-delete-frame) +(global-set-key :iconify-frame 'ignore-event) +(global-set-key :make-frame-visible 'ignore-event) + + +;These commands are defined in editfns.c +;but they are not assigned to keys there. +(setf (get 'narrow-to-region 'disabled) t) +(define-key *ctl-x-map* "n n" 'narrow-to-region) +(define-key *ctl-x-map* "n w" 'widen) +;; (define-key *ctl-x-map* "n" 'narrow-to-region) +;; (define-key *ctl-x-map* "w" 'widen) + +;; Quitting +(define-key *global-map* "ESC ESC ESC" 'keyboard-escape-quit) +(define-key *global-map* "C-g" 'keyboard-quit) + +(define-key *global-map* "C-j" 'newline-and-indent) +(define-key *global-map* "C-m" 'newline) +(define-key *global-map* "C-o" 'open-line) +(define-key *esc-map* "C-o" 'split-line) +(define-key *global-map* "C-q" 'quoted-insert) +(define-key *esc-map* "^" 'delete-indentation) +(define-key *esc-map* "\\" 'delete-horizontal-space) +(define-key *esc-map* "m" 'back-to-indentation) +(define-key *ctl-x-map* "C-o" 'delete-blank-lines) +(define-key *esc-map* " " 'just-one-space) +(define-key *esc-map* "z" 'zap-to-char) +(define-key *esc-map* "=" 'count-lines-region) +(define-key *ctl-x-map* "=" 'what-cursor-position) +(define-key *esc-map* ":" 'eval-expression) +;; Define ESC ESC : like ESC : for people who type ESC ESC out of habit. +(define-key *esc-map* (kbd "M-:") 'eval-expression) +;; Changed from C-x ESC so that function keys work following C-x. +(define-key *ctl-x-map* "\e\e" 'repeat-complex-command) +;; New binding analogous to M-:. +(define-key *ctl-x-map* "\M-:" 'repeat-complex-command) +(define-key *ctl-x-map* "u" 'advertised-undo) +;; Many people are used to typing C-/ on X terminals and getting C-_. +(define-key *global-map* "C-/" 'undo) +(define-key *global-map* "C-_" 'undo) +;; Richard said that we should not use C-x and I have +;; no idea whereas to bind it. Any suggestion welcome. -stef +;; (define-key *ctl-x-map* "U" 'undo-only) + +(define-key *esc-map* "!" 'shell-command) +(define-key *esc-map* "|" 'shell-command-on-region) + +(define-key *global-map* "C-x right" 'next-buffer) +(define-key *global-map* "C-x C-right" 'next-buffer) +(define-key *global-map* "C-x left" 'previous-buffer) +(define-key *global-map* "C-x C-left" 'previous-buffer) + +(let ((map *minibuffer-local-map*)) + (define-key map "M-n" 'next-history-element) + (define-key map :next 'next-history-element) + (define-key map :down 'next-history-element) + (define-key map "M-p" 'previous-history-element) + (define-key map :prior 'previous-history-element) + (define-key map :up 'previous-history-element) + (define-key map "M-s" 'next-matching-history-element) + (define-key map "M-r" 'previous-matching-history-element) + ;; Override the global binding (which calls indent-relative via + ;; indent-for-tab-command). The alignment that indent-relative tries to + ;; do doesn't make much sense here since the prompt messes it up. + (define-key map "TAB" 'self-insert-command)) + +(define-key *global-map* "C-u" 'universal-argument) +(loop for i from 0 to 9 do + (define-key *esc-map* (format nil "~d" i) 'digit-argument)) +(define-key *esc-map* "-" 'negative-argument) +;; Define control-digits. +(loop for i from 0 to 9 do + (define-key *global-map* (format nil "C-~d" i) 'digit-argument)) +(define-key *global-map* "C--" 'negative-argument) +;; Define control-meta-digits. +(loop for i from 0 to 9 do + (define-key *esc-map* (format nil "C-~d" i) 'digit-argument)) +(define-key *global-map* "C-M--" 'negative-argument) + +(define-key *global-map* "C-k" 'kill-line) +(define-key *global-map* "C-w" 'kill-region) +(define-key *esc-map* "w" 'kill-ring-save) +(define-key *esc-map* "C-w" 'append-next-kill) +(define-key *global-map* "C-y" 'yank) +(define-key *esc-map* "y" 'yank-pop) + +;; (define-key *ctl-x-map* "a" 'append-to-buffer) + +(define-key *global-map* "C-@" 'set-mark-command) +;; Many people are used to typing C-SPC and getting C-@. +(define-key *global-map* "C-SPC" 'set-mark-command) +(define-key *ctl-x-map* "C-x" 'exchange-point-and-mark) +(define-key *ctl-x-map* "C-@" 'pop-global-mark) +(define-key *ctl-x-map* "C-SPC" 'pop-global-mark) + +(define-key *global-map* "C-n" 'next-line) +(define-key *global-map* "C-p" 'previous-line) +(define-key *ctl-x-map* "C-n" 'set-goal-column) +(define-key *global-map* "C-a" 'move-beginning-of-line) +(define-key *global-map* "C-e" 'move-end-of-line) +(define-key *esc-map* "g" (make-sparse-keymap)) +(define-key *esc-map* "g M-g" 'goto-line) +(define-key *esc-map* "g g" 'goto-line) + +(define-key *esc-map* "g n" 'next-error) +(define-key *esc-map* "g M-n" 'next-error) +(define-key *ctl-x-map* "`" 'next-error) + +(define-key *esc-map* "g p" 'previous-error) +(define-key *esc-map* "g M-p" 'previous-error) + +;;(defun function-key-error () +;; (interactive) +;; (error "That function key is not bound to anything")) + +(define-key *global-map* :menu 'execute-extended-command) +(define-key *global-map* :find 'search-forward) + +;; Don't do this. We define in *function-key-map* instead. +;(define-key *global-map* [delete] 'backward-delete-char) + +;; natural bindings for terminal keycaps --- defined in X keysym order +(define-key *global-map* "C-S-backspace" 'kill-whole-line) +(define-key *global-map* "home" 'move-beginning-of-line) +(define-key *global-map* "C-home" 'beginning-of-buffer) +(define-key *global-map* "M-home" 'beginning-of-buffer-other-window) +(define-key *esc-map* "home" 'beginning-of-buffer-other-window) +(define-key *global-map* "left" 'backward-char) +(define-key *global-map* "up" 'previous-line) +(define-key *global-map* "right" 'forward-char) +(define-key *global-map* "down" 'next-line) +(define-key *global-map* "prior" 'scroll-down) +(define-key *global-map* "next" 'scroll-up) +(define-key *global-map* "C-up" 'backward-paragraph) +(define-key *global-map* "C-down" 'forward-paragraph) +(define-key *global-map* "C-prior" 'scroll-right) +(setf (get 'scroll-left 'disabled) t) +(define-key *global-map* "C-next" 'scroll-left) +(define-key *global-map* "M-next" 'scroll-other-window) +(define-key *esc-map* "next" 'scroll-other-window) +(define-key *global-map* "M-prior" 'scroll-other-window-down) +(define-key *esc-map* "prior" 'scroll-other-window-down) +(define-key *esc-map* "?\C-\S-v" 'scroll-other-window-down) +(define-key *global-map* "end" 'move-end-of-line) +(define-key *global-map* "C-end" 'end-of-buffer) +(define-key *global-map* "M-end" 'end-of-buffer-other-window) +(define-key *esc-map* "end" 'end-of-buffer-other-window) +(define-key *global-map* "begin" 'beginning-of-buffer) +(define-key *global-map* "M-begin" 'beginning-of-buffer-other-window) +(define-key *esc-map* "begin" 'beginning-of-buffer-other-window) +;; (define-key *global-map* "select" 'function-key-error) +;; (define-key *global-map* "print" 'function-key-error) +(define-key *global-map* "execute" 'execute-extended-command) +(define-key *global-map* "insert" 'overwrite-mode) +(define-key *global-map* "C-insert" 'kill-ring-save) +(define-key *global-map* "S-insert" 'yank) +;; `insertchar' is what term.c produces. Should we change term.c +;; to produce `insert' instead? +(define-key *global-map* "insertchar" 'overwrite-mode) +(define-key *global-map* "C-insertchar" 'kill-ring-save) +(define-key *global-map* "S-insertchar" 'yank) +(define-key *global-map* "undo" 'undo) +(define-key *global-map* "redo" 'repeat-complex-command) +(define-key *global-map* "again" 'repeat-complex-command) ; Sun keyboard +(define-key *global-map* "open" 'find-file) ; Sun +;; The following wouldn't work to interrupt running code since C-g is +;; treated specially in the event loop. +;; (define-key *global-map* "stop" 'keyboard-quit) ; Sun +;; (define-key *global-map* "clearline" 'function-key-error) +(define-key *global-map* "insertline" 'open-line) +(define-key *global-map* "deleteline" 'kill-line) +(define-key *global-map* "deletechar" 'delete-char) +;; (define-key *global-map* "backtab" 'function-key-error) +;; (define-key *global-map* "f1" 'function-key-error) +;; (define-key *global-map* "f2" 'function-key-error) +;; (define-key *global-map* "f3" 'function-key-error) +;; (define-key *global-map* "f4" 'function-key-error) +;; (define-key *global-map* "f5" 'function-key-error) +;; (define-key *global-map* "f6" 'function-key-error) +;; (define-key *global-map* "f7" 'function-key-error) +;; (define-key *global-map* "f8" 'function-key-error) +;; (define-key *global-map* "f9" 'function-key-error) +;; (define-key *global-map* "f10" 'function-key-error) +;; (define-key *global-map* "f11" 'function-key-error) +;; (define-key *global-map* "f12" 'function-key-error) +;; (define-key *global-map* "f13" 'function-key-error) +;; (define-key *global-map* "f14" 'function-key-error) +;; (define-key *global-map* "f15" 'function-key-error) +;; (define-key *global-map* "f16" 'function-key-error) +;; (define-key *global-map* "f17" 'function-key-error) +;; (define-key *global-map* "f18" 'function-key-error) +;; (define-key *global-map* "f19" 'function-key-error) +;; (define-key *global-map* "f20" 'function-key-error) +;; (define-key *global-map* "f21" 'function-key-error) +;; (define-key *global-map* "f22" 'function-key-error) +;; (define-key *global-map* "f23" 'function-key-error) +;; (define-key *global-map* "f24" 'function-key-error) +;; (define-key *global-map* "f25" 'function-key-error) +;; (define-key *global-map* "f26" 'function-key-error) +;; (define-key *global-map* "f27" 'function-key-error) +;; (define-key *global-map* "f28" 'function-key-error) +;; (define-key *global-map* "f29" 'function-key-error) +;; (define-key *global-map* "f30" 'function-key-error) +;; (define-key *global-map* "f31" 'function-key-error) +;; (define-key *global-map* "f32" 'function-key-error) +;; (define-key *global-map* "f33" 'function-key-error) +;; (define-key *global-map* "f34" 'function-key-error) +;; (define-key *global-map* "f35" 'function-key-error) +;; (define-key *global-map* "kp-backtab" 'function-key-error) +;; (define-key *global-map* "kp-space" 'function-key-error) +;; (define-key *global-map* "kp-tab" 'function-key-error) +;; (define-key *global-map* "kp-enter" 'function-key-error) +;; (define-key *global-map* "kp-f1" 'function-key-error) +;; (define-key *global-map* "kp-f2" 'function-key-error) +;; (define-key *global-map* "kp-f3" 'function-key-error) +;; (define-key *global-map* "kp-f4" 'function-key-error) +;; (define-key *global-map* "kp-multiply" 'function-key-error) +;; (define-key *global-map* "kp-add" 'function-key-error) +;; (define-key *global-map* "kp-separator" 'function-key-error) +;; (define-key *global-map* "kp-subtract" 'function-key-error) +;; (define-key *global-map* "kp-decimal" 'function-key-error) +;; (define-key *global-map* "kp-divide" 'function-key-error) +;; (define-key *global-map* "kp-0" 'function-key-error) +;; (define-key *global-map* "kp-1" 'function-key-error) +;; (define-key *global-map* "kp-2" 'function-key-error) +;; (define-key *global-map* "kp-3" 'function-key-error) +;; (define-key *global-map* "kp-4" 'function-key-error) +;; (define-key *global-map* "kp-5" 'recenter) +;; (define-key *global-map* "kp-6" 'function-key-error) +;; (define-key *global-map* "kp-7" 'function-key-error) +;; (define-key *global-map* "kp-8" 'function-key-error) +;; (define-key *global-map* "kp-9" 'function-key-error) +;; (define-key *global-map* "kp-equal" 'function-key-error) + +;; X11R6 distinguishes these keys from the non-kp keys. +;; Make them behave like the non-kp keys unless otherwise bound. +(define-key *function-key-map* "kp-home" "home") +(define-key *function-key-map* "kp-left" "left") +(define-key *function-key-map* "kp-up" "up") +(define-key *function-key-map* "kp-right" "right") +(define-key *function-key-map* "kp-down" "down") +(define-key *function-key-map* "kp-prior" "prior") +(define-key *function-key-map* "kp-next" "next") +(define-key *function-key-map* "M-kp-next" "M-next") +(define-key *function-key-map* "kp-end" "end") +(define-key *function-key-map* "kp-begin" "begin") +(define-key *function-key-map* "kp-insert" "insert") +(define-key *function-key-map* "backspace" "?\C-?") +(define-key *function-key-map* "delete" "?\C-?") +(define-key *function-key-map* "kp-delete" "?\C-?") +(define-key *function-key-map* "S-kp-end" "S-end") +(define-key *function-key-map* "S-kp-down" "S-down") +(define-key *function-key-map* "S-kp-next" "S-next") +(define-key *function-key-map* "S-kp-left" "S-left") +(define-key *function-key-map* "S-kp-right" "S-right") +(define-key *function-key-map* "S-kp-home" "S-home") +(define-key *function-key-map* "S-kp-up" "S-up") +(define-key *function-key-map* "S-kp-prior" "S-prior") +(define-key *function-key-map* "C-S-kp-end" "C-S-end") +(define-key *function-key-map* "C-S-kp-down" "C-S-down") +(define-key *function-key-map* "C-S-kp-next" "C-S-next") +(define-key *function-key-map* "C-S-kp-left" "C-S-left") +(define-key *function-key-map* "C-S-kp-right" "C-S-right") +(define-key *function-key-map* "C-S-kp-home" "C-S-home") +(define-key *function-key-map* "C-S-kp-up" "C-S-up") +(define-key *function-key-map* "C-S-kp-prior" "C-S-prior") +;; Don't bind shifted keypad numeric keys, they reportedly +;; interfere with the feature of some keyboards to produce +;; numbers when NumLock is off. +;(define-key *function-key-map* "S-kp-1" "S-end") +;(define-key *function-key-map* "S-kp-2" "S-down") +;(define-key *function-key-map* "S-kp-3" "S-next") +;(define-key *function-key-map* "S-kp-4" "S-left") +;(define-key *function-key-map* "S-kp-6" "S-right") +;(define-key *function-key-map* "S-kp-7" "S-home") +;(define-key *function-key-map* "S-kp-8" "S-up") +;(define-key *function-key-map* "S-kp-9" "S-prior") +(define-key *function-key-map* "C-S-kp-1" "C-S-end") +(define-key *function-key-map* "C-S-kp-2" "C-S-down") +(define-key *function-key-map* "C-S-kp-3" "C-S-next") +(define-key *function-key-map* "C-S-kp-4" "C-S-left") +(define-key *function-key-map* "C-S-kp-6" "C-S-right") +(define-key *function-key-map* "C-S-kp-7" "C-S-home") +(define-key *function-key-map* "C-S-kp-8" "C-S-up") +(define-key *function-key-map* "C-S-kp-9" "C-S-prior") + +(define-key *global-map* "mouse-movement" 'ignore) + +(define-key *global-map* "C-t" 'transpose-chars) +(define-key *esc-map* "t" 'transpose-words) +(define-key *esc-map* "C-t" 'transpose-sexps) +(define-key *ctl-x-map* "C-t" 'transpose-lines) + +(define-key *esc-map* ";" 'comment-dwim) +(define-key *esc-map* "j" 'indent-new-comment-line) +(define-key *esc-map* "C-j" 'indent-new-comment-line) +(define-key *ctl-x-map* ";" 'comment-set-column) +(define-key *ctl-x-map* "f" 'set-fill-column) +(define-key *ctl-x-map* "$" 'set-selective-display) + +(define-key *esc-map* "@" 'mark-word) +(define-key *esc-map* "f" 'forward-word) +(define-key *esc-map* "b" 'backward-word) +(define-key *esc-map* "d" 'kill-word) +(define-key *esc-map* "\177" 'backward-kill-word) + +(define-key *esc-map* "<" 'beginning-of-buffer) +(define-key *esc-map* ">" 'end-of-buffer) +(define-key *ctl-x-map* "h" 'mark-whole-buffer) +(define-key *esc-map* "\\" 'delete-horizontal-space) + +(defvar mode-specific-command-prefix (make-sparse-keymap)) +(defvar mode-specific-map mode-specific-command-prefix + "Keymap for characters following C-c.") +(define-key *global-map* "C-c" 'mode-specific-command-prefix) + +(global-set-key "M-right" 'forward-word) +(define-key *esc-map* "right" 'forward-word) +(global-set-key "M-left" 'backward-word) +(define-key *esc-map* "left" 'backward-word) +;; ilya@math.ohio-state.edu says these bindings are standard on PC editors. +(global-set-key "C-right" 'forward-word) +(global-set-key "C-left" 'backward-word) +;; This is not quite compatible, but at least is analogous +(global-set-key "C-delete" 'backward-kill-word) +(global-set-key "C-backspace" 'kill-word) +;; This is "move to the clipboard", or as close as we come. +(global-set-key "S-delete" 'kill-region) + +(global-set-key "C-M-left" 'backward-sexp) +(define-key *esc-map* "C-left" 'backward-sexp) +(global-set-key "C-M-right" 'forward-sexp) +(define-key *esc-map* "C-right" 'forward-sexp) +(global-set-key "C-M-up" 'backward-up-list) +(define-key *esc-map* "C-up" 'backward-up-list) +(global-set-key "C-M-down" 'down-list) +(define-key *esc-map* "C-down" 'down-list) +(global-set-key "C-M-home" 'beginning-of-defun) +(define-key *esc-map* "C-home" 'beginning-of-defun) +(global-set-key "C-M-end" 'end-of-defun) +(define-key *esc-map* "C-end" 'end-of-defun) + +(define-key *esc-map* "C-f" 'forward-sexp) +(define-key *esc-map* "C-b" 'backward-sexp) +(define-key *esc-map* "C-u" 'backward-up-list) +(define-key *esc-map* "C-@" 'mark-sexp) +(define-key *esc-map* "C-SPC" 'mark-sexp) +(define-key *esc-map* "C-d" 'down-list) +(define-key *esc-map* "C-k" 'kill-sexp) +;;; These are dangerous in various situations, +;;; so let's not encourage anyone to use them. +;;;(define-key *global-map* "C-M-delete" 'backward-kill-sexp) +;;;(define-key *global-map* "C-M-backspace" 'backward-kill-sexp) +(define-key *esc-map* "C-delete" 'backward-kill-sexp) +(define-key *esc-map* "C-backspace" 'backward-kill-sexp) +(define-key *esc-map* "C-n" 'forward-list) +(define-key *esc-map* "C-p" 'backward-list) +(define-key *esc-map* "C-a" 'beginning-of-defun) +(define-key *esc-map* "C-e" 'end-of-defun) +(define-key *esc-map* "C-h" 'mark-defun) +(define-key *ctl-x-map* "n d" 'narrow-to-defun) +(define-key *esc-map* "(" 'insert-parentheses) +(define-key *esc-map* ")" 'move-past-close-and-reindent) + +(define-key *ctl-x-map* "C-e" 'eval-last-sexp) + +(define-key *ctl-x-map* "m" 'compose-mail) +(define-key *ctl-x-4-map* "m" 'compose-mail-other-window) +(define-key *ctl-x-5-map* "m" 'compose-mail-other-frame) + +(define-key *ctl-x-map* "r C-@" 'point-to-register) +(define-key *ctl-x-map* "r C-SPC" 'point-to-register) +(define-key *ctl-x-map* "r SPC" 'point-to-register) +(define-key *ctl-x-map* "r j" 'jump-to-register) +(define-key *ctl-x-map* "r s" 'copy-to-register) +(define-key *ctl-x-map* "r x" 'copy-to-register) +(define-key *ctl-x-map* "r i" 'insert-register) +(define-key *ctl-x-map* "r g" 'insert-register) +(define-key *ctl-x-map* "r r" 'copy-rectangle-to-register) +(define-key *ctl-x-map* "r n" 'number-to-register) +(define-key *ctl-x-map* "r +" 'increment-register) +(define-key *ctl-x-map* "r c" 'clear-rectangle) +(define-key *ctl-x-map* "r k" 'kill-rectangle) +(define-key *ctl-x-map* "r d" 'delete-rectangle) +(define-key *ctl-x-map* "r y" 'yank-rectangle) +(define-key *ctl-x-map* "r o" 'open-rectangle) +(define-key *ctl-x-map* "r t" 'string-rectangle) +(define-key *ctl-x-map* "r w" 'window-configuration-to-register) +(define-key *ctl-x-map* "r f" 'frame-configuration-to-register) + +;; ;; These key bindings are deprecated; use the above C-x r map instead. +;; ;; We use these aliases so \[...] will show the C-x r bindings instead. +;; (defalias 'point-to-register-compatibility-binding 'point-to-register) +;; (defalias 'jump-to-register-compatibility-binding 'jump-to-register) +;; (defalias 'copy-to-register-compatibility-binding 'copy-to-register) +;; (defalias 'insert-register-compatibility-binding 'insert-register) +;; (define-key *ctl-x-map* "/" 'point-to-register-compatibility-binding) +;; (define-key *ctl-x-map* "j" 'jump-to-register-compatibility-binding) +;; (define-key *ctl-x-map* "x" 'copy-to-register-compatibility-binding) +;; (define-key *ctl-x-map* "g" 'insert-register-compatibility-binding) +;; (define-key *ctl-x-map* "r" 'copy-rectangle-to-register) + +(define-key *esc-map* "q" 'fill-paragraph) +;; (define-key *esc-map* "g" 'fill-region) +(define-key *ctl-x-map* "." 'set-fill-prefix) + +(define-key *esc-map* "{" 'backward-paragraph) +(define-key *esc-map* "}" 'forward-paragraph) +(define-key *esc-map* "h" 'mark-paragraph) +(define-key *esc-map* "a" 'backward-sentence) +(define-key *esc-map* "e" 'forward-sentence) +(define-key *esc-map* "k" 'kill-sentence) +(define-key *ctl-x-map* "DEL" 'backward-kill-sentence) + +(define-key *ctl-x-map* "[" 'backward-page) +(define-key *ctl-x-map* "]" 'forward-page) +(define-key *ctl-x-map* "C-p" 'mark-page) +(define-key *ctl-x-map* "l" 'count-lines-page) +(define-key *ctl-x-map* "n p" 'narrow-to-page) +;; (define-key *ctl-x-map* "p" 'narrow-to-page) + +(define-key *ctl-x-map* "a l" 'add-mode-abbrev) +(define-key *ctl-x-map* "a C-a" 'add-mode-abbrev) +(define-key *ctl-x-map* "a g" 'add-global-abbrev) +(define-key *ctl-x-map* "a +" 'add-mode-abbrev) +(define-key *ctl-x-map* "a i g" 'inverse-add-global-abbrev) +(define-key *ctl-x-map* "a i l" 'inverse-add-mode-abbrev) +;; (define-key *ctl-x-map* "a\C-h" 'inverse-add-global-abbrev) +(define-key *ctl-x-map* "a -" 'inverse-add-global-abbrev) +(define-key *ctl-x-map* "a e" 'expand-abbrev) +(define-key *ctl-x-map* "a '" 'expand-abbrev) +;; (define-key *ctl-x-map* "\C-a" 'add-mode-abbrev) +;; (define-key *ctl-x-map* "\+" 'add-global-abbrev) +;; (define-key *ctl-x-map* "\C-h" 'inverse-add-mode-abbrev) +;; (define-key *ctl-x-map* "\-" 'inverse-add-global-abbrev) +(define-key *esc-map* "'" 'abbrev-prefix-mark) +(define-key *ctl-x-map* "'" 'expand-abbrev) + +(define-key *ctl-x-map* "z" 'repeat) + +(define-key *ctl-x-4-map* "c" 'clone-indirect-buffer-other-window) + +;; Don't look for autoload cookies in this file. +;; Local Variables: +;; no-update-autoloads: t +;; End: + +;; arch-tag: 23b5c7e6-e47b-49ed-8c6c-ed213c5fffe0 +;;; bindings.el ends here diff --git a/src/lisp/subr.lisp b/src/lisp/subr.lisp index 04a099a..cd2b4a1 100644 --- a/src/lisp/subr.lisp +++ b/src/lisp/subr.lisp @@ -232,8 +232,269 @@ STRING should be given if the last search was by `string-match' on STRING." With optional non-nil ALL, force redisplay of all mode lines and header lines. This function also forces recomputation of the menu bar menus and the frame title." + (declare (ignore all)) + (error "unimplemented") ;; (if all (save-excursion (set-buffer (other-buffer)))) ;; (set-buffer-modified-p (buffer-modified-p)) ) +(defun add-minor-mode (toggle name &optional keymap after toggle-fun) + "Register a new minor mode. + +This is an XEmacs-compatibility function. Use `define-minor-mode' instead. + +TOGGLE is a symbol which is the name of a buffer-local variable that +is toggled on or off to say whether the minor mode is active or not. + +NAME specifies what will appear in the mode line when the minor mode +is active. NAME should be either a string starting with a space, or a +symbol whose value is such a string. + +Optional KEYMAP is the keymap for the minor mode that will be added +to `*minor-mode-map-list*'. + +Optional AFTER specifies that TOGGLE should be added after AFTER +in `*minor-mode-list*'. + +Optional TOGGLE-FUN is an interactive function to toggle the mode. +It defaults to (and should by convention be) TOGGLE. + +If TOGGLE has a non-nil `:included' property, an entry for the mode is +included in the mode-line minor mode menu. +If TOGGLE has a `:menu-tag', that is used for the menu item's label." + (unless (memq toggle minor-mode-list) + (push toggle minor-mode-list)) + + (unless toggle-fun (setq toggle-fun toggle)) + (unless (eq toggle-fun toggle) + (setf (get toggle :minor-mode-function) toggle-fun)) + ;; Add the name to the *minor-mode-list*. + (when name + (let ((existing (find toggle *minor-mode-list* :key 'first))) + (if existing + (setf (cdr existing) (list name)) + (let ((found (member after *minor-mode-list* :key 'first))) + (if found + (let ((rest (cdr found))) + (setf (cdr found) nil) + (nconc found (list (list toggle name)) rest)) + (push (cons (list toggle name) + *minor-mode-list*) *minor-mode-list*)))))) +;; FIXME: when menu support is added, use this code +;; ;; Add the toggle to the minor-modes menu if requested. +;; (when (get toggle :included) +;; (define-key mode-line-mode-menu +;; (vector toggle) +;; (list 'menu-item +;; (concat +;; (or (get toggle :menu-tag) +;; (if (stringp name) name (symbol-name toggle))) +;; (let ((mode-name (if (symbolp name) (symbol-value name)))) +;; (if (and (stringp mode-name) (string-match "[^ ]+" mode-name)) +;; (concat " (" (match-string 0 mode-name) ")")))) +;; toggle-fun +;; :button (cons :toggle toggle)))) + + ;; Add the map to the *minor-mode-map-list*. + (when keymap + (let ((existing (find toggle *minor-mode-map-list* :key 'minor-mode-map-variable))) + (if existing + (setf (minor-mode-map-keymap existing) keymap) + (let ((found (member after *minor-mode-map-list* :key 'minor-mode-map-variable))) + (if found + (let ((rest (cdr found))) + (setf (cdr found) nil) + (nconc found (list (make-minor-mode-map :variable toggle :keymap keymap)) rest)) + (push (make-minor-mode-map :variable toggle :keymap keymap) + *minor-mode-map-list*))))))) + + +(defun replace-regexp-in-string (regexp rep string &optional + fixedcase literal subexp start) + "Replace all matches for REGEXP with REP in STRING. + +Return a new string containing the replacements. + +Optional arguments FIXEDCASE, LITERAL and SUBEXP are like the +arguments with the same names of function `replace-match'. If START +is non-nil, start replacements at that index in STRING. + +REP is either a string used as the NEWTEXT arg of `replace-match' or a +function. If it is a function, it is called with the actual text of each +match, and its value is used as the replacement text. When REP is called, +the match-data are the result of matching REGEXP against a substring +of STRING. + +To replace only the first match (if any), make REGEXP match up to \\' +and replace a sub-expression, e.g. + (replace-regexp-in-string \"\\\\(foo\\\\).*\\\\'\" \"bar\" \" foo foo\" nil nil 1) + => \" bar foo\" +" + + ;; To avoid excessive consing from multiple matches in long strings, + ;; don't just call `replace-match' continually. Walk down the + ;; string looking for matches of REGEXP and building up a (reversed) + ;; list MATCHES. This comprises segments of STRING which weren't + ;; matched interspersed with replacements for segments that were. + ;; [For a `large' number of replacements it's more efficient to + ;; operate in a temporary buffer; we can't tell from the function's + ;; args whether to choose the buffer-based implementation, though it + ;; might be reasonable to do so for long enough STRING.] + (let ((l (length string)) + (start (or start 0)) + matches str mb me) + (with-match-data + (while (and (< start l) (string-match regexp string start)) + (setq mb (match-beginning 0) + me (match-end 0)) + ;; If we matched the empty string, make sure we advance by one char + (when (= me mb) (setq me (min l (1+ mb)))) + ;; Generate a replacement for the matched substring. + ;; Operate only on the substring to minimize string consing. + ;; Set up match data for the substring for replacement; + ;; presumably this is likely to be faster than munging the + ;; match data directly in Lisp. + (string-match regexp (setq str (substring string mb me))) + (setq matches + (cons (replace-match (if (stringp rep) + rep + (funcall rep (match-string 0 str))) + fixedcase literal str subexp) + (cons (substring string start mb) ; unmatched prefix + matches))) + (setq start me)) + ;; Reconstruct a string from the pieces. + (setq matches (cons (substring string start l) matches)) ; leftover + (apply #'concat (nreverse matches))))) + + +;;;; Key binding commands. + +(defcommand global-set-key ((key command) + (:key "Set key globally: ") + (:command "Set key ~a to command: ")) + "Give KEY a global binding as COMMAND. +COMMAND is the command definition to use; usually it is +a symbol naming an interactively-callable function. +KEY is a key sequence; noninteractively, it is a string or vector +of characters or event types, and non-ASCII characters with codes +above 127 (such as ISO Latin-1) can be included if you use a vector. + +Note that if KEY has a local binding in the current buffer, +that local binding will continue to shadow any global binding +that you make with this function." + ;;(interactive "KSet key globally: \nCSet key %s to command: ") + (or (vectorp key) (stringp key) (symbolp key) (clickp key) + (signal 'wrong-type-argument :type (list 'arrayp key))) + (define-key (current-global-map) key command)) + +(defcommand local-set-key ((key command) + (:key "Set key locally: ") + (:command "Set key ~a locally to command: ")) + "Give KEY a local binding as COMMAND. +COMMAND is the command definition to use; usually it is +a symbol naming an interactively-callable function. +KEY is a key sequence; noninteractively, it is a string or vector +of characters or event types, and non-ASCII characters with codes +above 127 (such as ISO Latin-1) can be included if you use a vector. + +The binding goes in the current buffer's local map, +which in most cases is shared with all other buffers in the same major mode." + ;;(interactive "KSet key locally: \nCSet key %s locally to command: ") + (let ((map (current-local-map))) + (or map + (use-local-map (setq map (make-sparse-keymap)))) + (or (vectorp key) (stringp key) + (signal 'wrong-type-argument (list 'arrayp key))) + (define-key map key command))) + +(defun global-unset-key (key) + "Remove global binding of KEY. +KEY is a string or vector representing a sequence of keystrokes." + (interactive "kUnset key globally: ") + (global-set-key key nil)) + +(defun local-unset-key (key) + "Remove local binding of KEY. +KEY is a string or vector representing a sequence of keystrokes." + (interactive "kUnset key locally: ") + (if (current-local-map) + (local-set-key key nil)) + nil) + + +;;;; substitute-key-definition and its subroutines. + +(defvar key-substitution-in-progress nil + "Used internally by `substitute-key-definition'.") + +(defun substitute-key-definition (olddef newdef keymap &optional oldmap prefix) + "Replace OLDDEF with NEWDEF for any keys in KEYMAP now defined as OLDDEF. +In other words, OLDDEF is replaced with NEWDEF where ever it appears. +Alternatively, if optional fourth argument OLDMAP is specified, we redefine +in KEYMAP as NEWDEF those keys which are defined as OLDDEF in OLDMAP. + +If you don't specify OLDMAP, you can usually get the same results +in a cleaner way with command remapping, like this: + \(define-key KEYMAP [remap OLDDEF] NEWDEF) +\n(fn OLDDEF NEWDEF KEYMAP &optional OLDMAP)" + ;; Don't document PREFIX in the doc string because we don't want to + ;; advertise it. It's meant for recursive calls only. Here's its + ;; meaning + + ;; If optional argument PREFIX is specified, it should be a key + ;; prefix, a string. Redefined bindings will then be bound to the + ;; original key, with PREFIX added at the front. + (or prefix (setq prefix "")) + (let* ((scan (or oldmap keymap)) + (prefix1 (vconcat prefix [nil])) + (key-substitution-in-progress + (cons scan key-substitution-in-progress))) + ;; Scan OLDMAP, finding each char or event-symbol that + ;; has any definition, and act on it with hack-key. + (map-keymap + (lambda (char defn) + (aset prefix1 (length prefix) char) + (substitute-key-definition-key defn olddef newdef prefix1 keymap)) + scan))) + +(defun substitute-key-definition-key (defn olddef newdef prefix keymap) + (let (inner-def skipped menu-item) + ;; Find the actual command name within the binding. + (el:if (eq (car-safe defn) 'menu-item) + (setq menu-item defn defn (nth 2 defn)) + ;; Skip past menu-prompt. + (while (stringp (car-safe defn)) + (push (pop defn) skipped)) + ;; Skip past cached key-equivalence data for menu items. + (if (consp (car-safe defn)) + (setq defn (cdr defn)))) + (el:if (or (eq defn olddef) + ;; Compare with equal if definition is a key sequence. + ;; That is useful for operating on function-key-map. + (and (or (stringp defn) (vectorp defn)) + (equal defn olddef))) + (define-key keymap prefix + (if menu-item + (let ((copy (copy-sequence menu-item))) + (setcar (nthcdr 2 copy) newdef) + copy) + (nconc (nreverse skipped) newdef))) + ;; Look past a symbol that names a keymap. + (setq inner-def + (or (indirect-function defn t) defn)) + ;; For nested keymaps, we use `inner-def' rather than `defn' so as to + ;; avoid autoloading a keymap. This is mostly done to preserve the + ;; original non-autoloading behavior of pre-map-keymap times. + (if (and (keymapp inner-def) + ;; Avoid recursively scanning + ;; where KEYMAP does not have a submap. + (let ((elt (lookup-key keymap prefix))) + (or (null elt) (natnump elt) (keymapp elt))) + ;; Avoid recursively rescanning keymap being scanned. + (not (memq inner-def key-substitution-in-progress))) + ;; If this one isn't being scanned already, scan it now. + (substitute-key-definition olddef newdef keymap inner-def prefix))))) + + (provide :lice-0.1/subr) diff --git a/src/main.lisp b/src/main.lisp index 08769f8..6df120b 100644 --- a/src/main.lisp +++ b/src/main.lisp @@ -49,7 +49,7 @@ #+movitz (make-default-movitz-frame (get-buffer "*scratch*"))) *selected-frame* (car *frame-list*) *process-list* nil) - (make-global-keymaps) + ;;(make-global-keymaps) (catch 'lice-quit #+clisp (ext:with-keyboard diff --git a/src/recursive-edit.lisp b/src/recursive-edit.lisp index 35ae865..401e2fc 100644 --- a/src/recursive-edit.lisp +++ b/src/recursive-edit.lisp @@ -13,10 +13,10 @@ ;; restore the last command (*last-command* *last-command*) (ret (catch 'exit - (with-lice-debugger + ;;(with-lice-debugger (loop (frame-render (selected-frame)) - (top-level-next-event)))))) + (top-level-next-event))))) ;; return the ret val. (dformat +debug-v+ "ret ~a~%" ret) (when ret diff --git a/src/search.lisp b/src/search.lisp index a4769f8..592f3e6 100644 --- a/src/search.lisp +++ b/src/search.lisp @@ -54,6 +54,45 @@ STRING should be given if the last search was by `string-match' on STRING." (substring string (match-beginning num) (match-end num)) (buffer-substring (match-beginning num) (match-end num))))) +(defun replace-match (newtext &optional fixedcase literal string subexp) + "Replace text matched by last search with NEWTEXT. +Leave point at the end of the replacement text. + +If second arg FIXEDCASE is non-nil, do not alter case of replacement text. +Otherwise maybe capitalize the whole text, or maybe just word initials, +based on the replaced text. +If the replaced text has only capital letters +and has at least one multiletter word, convert NEWTEXT to all caps. +Otherwise if all words are capitalized in the replaced text, +capitalize each word in NEWTEXT. + +If third arg LITERAL is non-nil, insert NEWTEXT literally. +Otherwise treat `\\' as special: + `\\&' in NEWTEXT means substitute original matched text. + `\\N' means substitute what matched the Nth `\\(...\\)'. + If Nth parens didn't match, substitute nothing. + `\\\\' means insert one `\\'. +Case conversion does not apply to these substitutions. + +FIXEDCASE and LITERAL are optional arguments. + +The optional fourth argument STRING can be a string to modify. +This is meaningful when the previous match was done against STRING, +using `string-match'. When used this way, `replace-match' +creates and returns a new string made by copying STRING and replacing +the part of STRING that was matched. + +The optional fifth argument SUBEXP specifies a subexpression; +it says to replace just that subexpression with NEWTEXT, +rather than replacing the entire matched text. +This is, in a vague sense, the inverse of using `\\N' in NEWTEXT; +`\\N' copies subexp N into NEWTEXT, but using N as SUBEXP puts +NEWTEXT in place of subexp N. +This is useful only after a regular expression search or match, +since only regular expressions have distinguished subexpressions." + (declare (ignore newtext fixedcase literal string subexp)) + (error "unimplemented")) + (defun match-string-no-properties (num &optional string) "Return string of text matched by last search, without text properties. diff --git a/src/window.lisp b/src/window.lisp index 15c25e4..f60d6b8 100644 --- a/src/window.lisp +++ b/src/window.lisp @@ -976,4 +976,21 @@ WINDOW defaults to the selected window. This is updated by redisplay or by calling `set-window-start'." (marker-position (window-top window))) + +;;; Key bindings +(define-key *ctl-x-map* "1" 'delete-other-windows) +(define-key *ctl-x-map* "2" 'split-window) +(define-key *ctl-x-map* "0" 'delete-window) +(define-key *ctl-x-map* "o" 'other-window) +(define-key *ctl-x-map* "^" 'enlarge-window) +(define-key *ctl-x-map* "<" 'scroll-left) +(define-key *ctl-x-map* ">" 'scroll-right) + +(define-key *global-map* "C-v" 'scroll-up) +(define-key *global-map* "M-C-v" 'scroll-other-window) +(define-key *global-map* "M-v" 'scroll-down) + +(define-key *global-map* "C-l" 'recenter) +(define-key *global-map* "M-r" 'move-to-window-line) + (provide :lice-0.1/window)