Mercurial > hg > xemacs-beta
diff lisp/egg/egg.el @ 98:0d2f883870bc r20-1b1
Import from CVS: tag r20-1b1
author | cvs |
---|---|
date | Mon, 13 Aug 2007 09:13:56 +0200 |
parents | 131b0175ea99 |
children | fe104dbd9147 |
line wrap: on
line diff
--- a/lisp/egg/egg.el Mon Aug 13 09:12:43 2007 +0200 +++ b/lisp/egg/egg.el Mon Aug 13 09:13:56 2007 +0200 @@ -61,8 +61,11 @@ ;;; (eval-when (load) (require 'wnn-client)) ;;; -(defvar egg-version "3.09" "Version number of this version of Egg. ") +; last master version +;;; (defvar egg-version "3.09" "Version number of this version of Egg. ") ;;; Last modified date: Fri Sep 25 12:59:00 1992 +(defvar egg-version "3.09 xemacs" "Version number of this version of Egg. ") +;;; Last modified date: Wed Feb 05 20:45:00 1997 ;;;; $B=$@5MW5a%j%9%H(B @@ -70,6 +73,11 @@ ;;;; $B=$@5%a%b(B +;;; 97.2.05 modified by J.Hein <jhod@po.iijnet.or.jp> +;;; Lots of mods to make it XEmacs workable. Most fixes revolve around the fact that +;;; Mule/et al assumes that all events are keypress events unless specified otherwise. +;;; Also modified to work with the new charset names and API + ;;; 95.6.5 modified by S.Tomura <tomura@etl.go.jp> ;;; $BJQ49D>8e$KO"B3$7$FJQ49$9$k>l9g$rG'<1$9$k$?$a$K!"(B"-in-cont" $B$K4XO"$7$?(B ;;; $BItJ,$rDI2C$7$?!#!J$3$NItJ,$O>-Mh:F=$@5$9$kM=Dj!#!K(B @@ -384,12 +392,24 @@ ;;;; Aug-25-88 toroku-region$B$GEPO?$9$kJ8;zNs$+$i(Bno graphic character$B$r(B ;;;; $B<+F0E*$K=|$/$3$H$K$7$?!#(B +(provide 'egg) + ;; XEmacs addition: (and remove disable-undo variable) ;; For Emacs V18/Nemacs compatibility (and (not (fboundp 'buffer-disable-undo)) (fboundp 'buffer-flush-undo) (defalias 'buffer-disable-undo 'buffer-flush-undo)) +;; 97.2.4 Created by J.Hein to simulate Mule-2.3 +(defun read-event () + "Cheap 'n cheesy event filter to facilitate translation from Mule-2.3" + (setq event (make-event)) + (while (progn + (next-event event) + (not (key-press-event-p event))) + (dispatch-event event)) + (event-key event)) + (eval-when-compile (require 'egg-jsymbol)) ;;;---------------------------------------------------------------------- @@ -430,16 +450,13 @@ ;;; ;;;; -(defun characterp (form) - (numberp form)) - (defun coerce-string (form) (cond((stringp form) form) ((characterp form) (char-to-string form)))) (defun coerce-internal-string (form) (cond((stringp form) - (if (= (chars-in-string form) 1) + (if (= (length form) 1) (string-to-char form) form)) ((characterp form) form))) @@ -471,7 +488,7 @@ (while (null (setq val (read-jis-code-from-string str))) (beep) (setq str (read-from-minibuffer prompt str))) - (insert (make-character lc-jp (car val) (cdr val))))) + (insert (make-char (find-charset 'japanese-jisx0208) (car val) (cdr val))))) (defun hexadigit-value (ch) (cond((and (<= ?0 ch) (<= ch ?9)) @@ -765,7 +782,7 @@ (+ p menu:*select-item-no*))) (defun menu:select-goto-item-position (pos) - (let ((m 0) (i 0) (p 0)) + (let ((m 0) (p 0)) (while (<= (+ p (length (nth m menu:*select-menus*))) pos) (setq p (+ p (length (nth m menu:*select-menus*)))) (setq m (1+ m))) @@ -817,17 +834,17 @@ (defun menu:item-string (item) (cond((stringp item) item) - ((numberp item) (char-to-string item)) + ((characterp item) (char-to-string item)) ((consp item) (if menu:*display-item-value* (format "%s [%s]" (cond ((stringp (car item)) (car item)) - ((numberp (car item)) (char-to-string (car item))) + ((characterp (car item)) (char-to-string (car item))) (t "")) (cdr item)) (cond ((stringp (car item)) (car item)) - ((numberp (car item)) + ((characterp (car item)) (char-to-string (car item))) (t "")))) (t ""))) @@ -905,7 +922,7 @@ (let ((ch (preceding-char))) (cond( (<= ch ?$B%s(B) (delete-char -1) - (insert (make-character lc-jp ?\244 (char-component ch 2)))))))) + (insert (make-char (find-charset 'japanese-jisx0208) 36 (char-octet ch 1)))))))) (defun hiragana-paragraph () "hiragana paragraph at or after point." @@ -931,12 +948,11 @@ (defun katakana-region (start end) (interactive "r") - (let ((point (point))) - (goto-char start) - (while (re-search-forward kanji-hiragana end end) - (let ((ch (char-component (preceding-char) 2))) - (delete-char -1) - (insert (make-character lc-jp ?\245 ch)))))) + (goto-char start) + (while (re-search-forward kanji-hiragana end end) + (let ((ch (char-octet (preceding-char) 1))) + (delete-char -1) + (insert (make-char (find-charset 'japanese-jisx0208) 37 ch))))) (defun katakana-paragraph () "katakana paragraph at or after point." @@ -967,8 +983,8 @@ (goto-char (point-min)) (while (re-search-forward "\\cS\\|\\cA" (point-max) (point-max)) (let* ((ch (preceding-char)) - (ch1 (char-component ch 1)) - (ch2 (char-component ch 2))) + (ch1 (char-octet ch 0)) + (ch2 (char-octet ch 1))) (cond ((= ?\241 ch1) (let ((val (cdr (assq ch2 *hankaku-alist*)))) (if val (progn @@ -1054,7 +1070,7 @@ (delete-char -1) (let ((zen (cdr (assq ch *zenkaku-alist*)))) (if zen (insert zen) - (insert (make-character lc-jp ?\243 (+ ?\200 ch))))))))))) + (insert (make-char (find-charset 'japanese-jisx0208) 38 ch)))))))))) (defun zenkaku-paragraph () "zenkaku paragraph at or after point." @@ -1339,7 +1355,7 @@ (and (consp action) (or (stringp (car action)) (and (consp (car action)) - (numberp (car (car action)))) + (characterp (car (car action)))) (null (car action))) (or (null (car (cdr action))) (stringp (car (cdr action))))))) @@ -1570,7 +1586,8 @@ ;;; (defvar its:*buff-s* (make-marker)) -(defvar its:*buff-e* (set-marker-type (make-marker) t)) +(defvar its:*buff-e* (make-marker)) +(set-marker-insertion-type its:*buff-e* t) ;;; STATE unread ;;; |<-s p->|<- e ->| @@ -1628,7 +1645,7 @@ (defun its:peek-char () (if (= (point) its:*buff-e*) (if its:*interactive* - (setq unread-command-events (list (read-event))) + (setq unread-command-events (list (character-to-event(read-event)))) nil) (following-char))) @@ -1648,26 +1665,27 @@ (if its:*char-from-buff* (save-excursion (its:insert-char ch)) - (if ch (setq unread-command-events (list ch))))) + (if ch (setq unread-command-events (list (character-to-event ch)))))) (defun its:insert-char (ch) (insert ch)) (defun its:ordinal-charp (ch) - (and (numberp ch) (<= ch 127) + (and (characterp ch) (<= ch 127) (eq (lookup-key fence-mode-map (char-to-string ch)) 'fence-self-insert-command))) (defun its:delete-charp (ch) - (and (numberp ch) (<= ch 127) + (and (characterp ch) (<= ch 127) (eq (lookup-key fence-mode-map (char-to-string ch)) 'fence-backward-delete-char))) (defun fence-self-insert-command () (interactive) + (setq ch (event-to-character last-command-event)) (cond((or (not egg:*input-mode*) - (null (get-next-map its:*current-map* last-command-event))) - (insert last-command-event)) + (null (get-next-map its:*current-map* ch))) + (insert ch)) (t - (insert last-command-event) + (insert ch) (its:translate-region (1- (point)) (point) t)))) ;;; @@ -1707,7 +1725,7 @@ (if quit-flag (progn (setq quit-flag nil) - (setq unread-command-events (list ?\^G)))))) + (setq unread-command-events (list (character-to-event ?\^G))))))) (defun car-string-lessp (item1 item2) (string-lessp (car item1) (car item2))) @@ -1804,7 +1822,7 @@ (cons (list string (let ((action-output (action-output action))) (cond((and (consp action-output) - (numberp (car action-output))) + (characterp (car action-output))) (format "%s..." (nth (car action-output) (cdr action-output)))) ((stringp action-output) @@ -1888,7 +1906,7 @@ (setq action (get-action newmap)) (cond - ((and its:*interactive* (not its:*char-from-buff*) (numberp ch) (= ch ?\^@)) + ((and its:*interactive* (not its:*char-from-buff*) (characterp ch) (= ch ?\^@)) (delete-region its:*buff-s* (point)) (let ((i 1)) (while (<= i its:*level*) @@ -2081,7 +2099,7 @@ (set-marker its:*buff-s* nil) (set-marker its:*buff-e* nil) - (if (and its:*interactive* ch) (setq unread-command-events (list ch))) + (if (and its:*interactive* ch) (setq unread-command-events (list (character-to-event ch)))) )) ;;;---------------------------------------------------------------------- @@ -2189,39 +2207,38 @@ ;;; ;;; -(defvar its:*reset-mode-line-format* nil) - -(if its:*reset-mode-line-format* - (setq-default mode-line-format - (cdr mode-line-format))) - -(if (not (egg:find-symbol-in-tree 'mode-line-egg-mode mode-line-format)) +(defvar its:*reset-modeline-format* nil) + +(if its:*reset-modeline-format* + (setq-default modeline-format + (cdr modeline-format))) + +(if (not (egg:find-symbol-in-tree 'mode-line-egg-mode modeline-format)) (setq-default - mode-line-format - (cons (list 'mc-flag - (list 'display-minibuffer-mode-in-minibuffer - ;;; minibuffer mode in minibuffer - (list - (list 'its:*previous-map* "<" "[") - 'mode-line-egg-mode - (list 'its:*previous-map* ">" "]") - ) + modeline-format + (cons (list 'display-minibuffer-mode-in-minibuffer + ;;; minibuffer mode in minibuffer + (list + (list 'its:*previous-map* "<" "[") + 'mode-line-egg-mode + (list 'its:*previous-map* ">" "]") + ) ;;;; minibuffer mode in mode line - (list - (list 'minibuffer-window-selected - (list 'display-minibuffer-mode - "m" - " ") + (list + (list 'minibuffer-window-selected + (list 'display-minibuffer-mode + "m" " ") - (list 'its:*previous-map* "<" "[") - (list 'minibuffer-window-selected - (list 'display-minibuffer-mode - 'mode-line-egg-mode-in-minibuffer - 'mode-line-egg-mode) + " ") + (list 'its:*previous-map* "<" "[") + (list 'minibuffer-window-selected + (list 'display-minibuffer-mode + 'mode-line-egg-mode-in-minibuffer 'mode-line-egg-mode) - (list 'its:*previous-map* ">" "]") - ))) - mode-line-format))) + 'mode-line-egg-mode) + (list 'its:*previous-map* ">" "]") + )) + modeline-format))) ;;; ;;; minibuffer $B$G$N%b!<%II=<($r$9$k$?$a$K(B nemacs 4 $B$GDj5A$5$l$?(B @@ -2276,8 +2293,7 @@ (progn (setq its:*current-map* (its:get-mode-map name)) (egg:mode-line-display)) - (beep)) - ) + (beep))) (defvar its:*select-mode-menu* '(menu "Mode:" nil)) @@ -2351,11 +2367,10 @@ (defun toggle-egg-mode () (interactive) - (if mc-flag - (if egg:*mode-on* (fence-toggle-egg-mode) - (progn - (setq egg:*mode-on* t) - (egg:mode-line-display))))) + (if egg:*mode-on* (fence-toggle-egg-mode) + (progn + (setq egg:*mode-on* t) + (egg:mode-line-display)))) (defun fence-toggle-egg-mode () (interactive) @@ -2418,7 +2433,7 @@ (defconst egg:*fence-close* "|" "*$B%U%'%s%9$N=*E@$r<($9J8;zNs(B") (defconst egg:*fence-face* nil "*$B%U%'%s%9I=<($KMQ$$$k(B face $B$^$?$O(B nil") (make-variable-buffer-local - (defvar egg:*fence-overlay* nil "$B%U%'%s%9I=<(MQ(B overlay")) + (defvar egg:*fence-extent* nil "$B%U%'%s%9I=<(MQ(B extent")) (defvar egg:*face-alist* '(("nil" . nil) @@ -2442,18 +2457,16 @@ (setq egg:*fence-open* (or open "") egg:*fence-close* (or close "") egg:*fence-face* face) - (if (overlayp egg:*fence-overlay*) - (overlay-put egg:*fence-overlay* 'face egg:*fence-face*)) + (if (extentp egg:*fence-extent*) + (set-extent-property egg:*fence-extent* 'face egg:*fence-face*)) t) (error "Wrong type of argument: %s %s %s" open close face))) -;(defconst egg:*region-start* (make-marker)) -;(defconst egg:*region-end* (set-marker-type (make-marker) t)) (defvar egg:*region-start* nil) -(defvar egg:*region-end* nil) (make-variable-buffer-local 'egg:*region-start*) +(set-default 'egg:*region-start* nil) +(defvar egg:*region-end* nil) (make-variable-buffer-local 'egg:*region-end*) -(set-default 'egg:*region-start* nil) (set-default 'egg:*region-end* nil) (defvar egg:*global-map-backup* nil) (defvar egg:*local-map-backup* nil) @@ -2470,10 +2483,9 @@ (defun egg-self-insert-command (arg) (interactive "p") (if (and (not buffer-read-only) - mc-flag egg:*mode-on* egg:*input-mode* (not egg:*in-fence-mode*) ;;; inhibit recursive fence mode - (not (= last-command-event ? ))) + (not (= (event-to-character last-command-event) ? ))) (egg:enter-fence-mode-and-self-insert) (progn ;; treat continuous 20 self insert as a single undo chunk. @@ -2492,7 +2504,7 @@ (if (<= 1 arg) (funcall self-insert-after-hook (- (point) arg) (point))) - (if (= last-command-event ? ) (egg:do-auto-fill)))))) + (if (= (event-to-character last-command-event) ? ) (egg:do-auto-fill)))))) ;; ;; $BA03NDjJQ49=hM}4X?t(B @@ -2525,8 +2537,8 @@ (setq egg:*fence-open-in-cont* (or open "") egg:*fence-close-in-cont* (or close "") egg:*fence-face-in-cont* face) - (if (overlayp egg:*fence-overlay*) - (overlay-put egg:*fence-overlay* 'face egg:*fence-face*)) + (if (extentp egg:*fence-extent*) + (set-extent-property egg:*fence-extent* 'face egg:*fence-face*)) t) (error "Wrong type of argument: %s %s %s" open close face))) @@ -2568,16 +2580,16 @@ (defun egg:fence-face-on () (if egg:*fence-face* (progn - (if (overlayp egg:*fence-overlay*) + (if (extentp egg:*fence-extent*) nil - (setq egg:*fence-overlay* (make-overlay 1 1 nil t)) - (if egg:*fence-face* (overlay-put egg:*fence-overlay* 'face egg:*fence-face*))) - (move-overlay egg:*fence-overlay* egg:*region-start* egg:*region-end* ) ))) + (setq egg:*fence-extent* (make-extent 1 1 nil t)) + (if egg:*fence-face* (set-extent-property egg:*fence-extent* 'face egg:*fence-face*))) + (set-extent-endpoints egg:*fence-extent* egg:*region-start* egg:*region-end* ) ))) (defun egg:fence-face-off () (and egg:*fence-face* - (overlayp egg:*fence-overlay*) - (delete-overlay egg:*fence-overlay*) )) + (extentp egg:*fence-extent*) + (detach-extent egg:*fence-extent*) )) (defun enter-fence-mode () ;; XEmacs change: @@ -2594,7 +2606,7 @@ (or (markerp egg:*region-start*) (setq egg:*region-start* (make-marker))) (set-marker egg:*region-start* (point)) (insert egg:*fence-close*) - (or (markerp egg:*region-end*) (setq egg:*region-end* (set-marker-type (make-marker) t))) + (or (markerp egg:*region-end*) (set-marker-insertion-type (setq egg:*region-end* (make-marker)) t)) (set-marker egg:*region-end* egg:*region-start*) (egg:fence-face-on) (goto-char egg:*region-start*) @@ -2740,7 +2752,7 @@ (defvar fence-mode-map (make-keymap)) -(substitute-key-definition 'self-insert-command +(substitute-key-definition 'egg-self-insert-command 'fence-self-insert-command fence-mode-map global-map)