Mercurial > hg > xemacs-beta

comparison lisp/cmdloop.el @ 1333:1b0339b048ce

Find changesets by keywords (author, files, the commit message), revision number or hash, or revset expression.
[xemacs-hg @ 2003-03-02 09:38:37 by ben] To: xemacs-patches@xemacs.org PROBLEMS: Include nt/PROBLEMS and update. Add note about incremental linking badness. cmdloop.el, custom.el, dumped-lisp.el, files.el, keydefs.el, keymap.el, lisp-mode.el, make-docfile.el, replace.el, simple.el, subr.el, view-less.el, wid-edit.el: Lots of syncing with FSF 21.2. Use if-fboundp in wid-edit.el. New file newcomment.el from FSF. internals/internals.texi: Fix typo. (Build-Time Dependencies): New node. PROBLEMS: Delete. config.inc.samp, xemacs.mak: Eliminate HAVE_VC6, use SUPPORT_EDIT_AND_CONTINUE in its place. No incremental linking unless SUPPORT_EDIT_AND_CONTINUE, since it can cause nasty crashes in pdump. Put warnings about this in config.inc.samp. Report the full compile flags used for src and lib-src in the Installation output. alloc.c, lisp.h, ralloc.c, regex.c: Use ALLOCA() in regex.c to avoid excessive stack allocation. Also fix subtle problem with REL_ALLOC() -- any call to malloc() (direct or indirect) may relocate rel-alloced data, causing buffer text to shift. After any such call, regex must update all its pointers to such data. Add a system, when ERROR_CHECK_MALLOC, whereby regex.c indicates all the places it is prepared to handle malloc()/realloc()/free(), and any calls anywhere in XEmacs outside of this will trigger an abort. alloc.c, dialog-msw.c, eval.c, event-stream.c, general-slots.h, insdel.c, lisp.h, menubar-msw.c, menubar-x.c: Change *run_hook*_trapping_problems to take a warning class, not a string. Factor out code to issue warnings, add flag to call_trapping_problems() to postpone warning issue, and make *run_hook*_trapping_problems issue their own warnings tailored to the hook, postponed in the case of safe_run_hook_trapping_problems() so that the appropriate message can be issued about resetting to nil only when not `quit'. Make record_unwind_protect_restoring_int() non-static. dumper.c: Issue notes about incremental linking problems under Windows. fileio.c: Mule-ize encrypt/decrypt-string code. text.h: Spacing changes.
author ben
date Sun, 02 Mar 2003 09:38:54 +0000
parents 37bdd24225ef
children 01c57eb70ae9
comparison
equal deleted inserted replaced
1332:6aa23bb3da6b 1333:1b0339b048ce
1 ;;; cmdloop.el --- support functions for the top-level command loop. 1 ;;; cmdloop.el --- support functions for the top-level command loop.
2 2
3 ;; Copyright (C) 1992-4, 1997 Free Software Foundation, Inc. 3 ;; Copyright (C) 1992-4, 1997 Free Software Foundation, Inc.
4 ;; Copyright (C) 2001, 2002 Ben Wing. 4 ;; Copyright (C) 2001, 2002, 2003 Ben Wing.
5 5
6 ;; Author: Richard Mlynarik 6 ;; Author: Richard Mlynarik
7 ;; Date: 8-Jul-92 7 ;; Date: 8-Jul-92
8 ;; Maintainer: XEmacs Development Team 8 ;; Maintainer: XEmacs Development Team
9 ;; Keywords: internal, dumped 9 ;; Keywords: internal, dumped
24 ;; along with XEmacs; see the file COPYING. If not, write to the 24 ;; along with XEmacs; see the file COPYING. If not, write to the
25 ;; Free Software Foundation, 59 Temple Place - Suite 330, 25 ;; Free Software Foundation, 59 Temple Place - Suite 330,
26 ;; Boston, MA 02111-1307, USA. 26 ;; Boston, MA 02111-1307, USA.
27 27
28 ;;; Synched up with: FSF 19.30. (Some of the stuff below is in FSF's subr.el.) 28 ;;; Synched up with: FSF 19.30. (Some of the stuff below is in FSF's subr.el.)
29 ;;; Some parts synched with FSF 21.2.
29 30
30 ;;; Commentary: 31 ;;; Commentary:
31 32
32 ;; This file is dumped with XEmacs. 33 ;; This file is dumped with XEmacs.
33 34
517 (setq ch (event-to-character event)) 518 (setq ch (event-to-character event))
518 (deallocate-event event) 519 (deallocate-event event)
519 (null ch))) 520 (null ch)))
520 ch)) 521 ch))
521 522
523 ;;;; Input and display facilities.
524
525 ;; BEGIN SYNCHED WITH FSF 21.2.
526
527 (defvar read-quoted-char-radix 8
528 "*Radix for \\[quoted-insert] and other uses of `read-quoted-char'.
529 Legitimate radix values are 8, 10 and 16.")
530
531 (custom-declare-variable-early
532 'read-quoted-char-radix 8
533 "*Radix for \\[quoted-insert] and other uses of `read-quoted-char'.
534 Legitimate radix values are 8, 10 and 16."
535 :type '(choice (const 8) (const 10) (const 16))
536 :group 'editing-basics)
537
522 (defun read-quoted-char (&optional prompt) 538 (defun read-quoted-char (&optional prompt)
523 "Like `read-char', except that if the first character read is an octal 539 "Like `read-char', but do not allow quitting.
524 digit, we read up to two more octal digits and return the character 540 Also, if the first character read is an octal digit,
525 represented by the octal number consisting of those digits. 541 we read any number of octal digits and return the
526 Optional argument PROMPT specifies a string to use to prompt the user." 542 specified character code. Any nondigit terminates the sequence.
527 (let ((count 0) (code 0) done 543 If the terminator is RET, it is discarded;
544 any other terminator is used itself as input.
545
546 The optional argument PROMPT specifies a string to use to prompt the user.
547 The variable `read-quoted-char-radix' controls which radix to use
548 for numeric input."
549 (let (;(message-log-max nil)
550 done (first t) (code 0) char event
528 (prompt (and prompt (gettext prompt))) 551 (prompt (and prompt (gettext prompt)))
529 char event) 552 )
530 (while (and (not done) (< count 3)) 553 (while (not done)
531 (let ((inhibit-quit (zerop count)) 554 (let ((inhibit-quit first)
532 ;; Don't let C-h get the help message--only help function keys. 555 ;; Don't let C-h get the help message--only help function keys.
533 (help-char nil) 556 (help-char nil)
534 (help-form 557 (help-form
535 "Type the special character you want to use, 558 "Type the special character you want to use,
536 or three octal digits representing its character code.")) 559 or the octal character code.
560 RET terminates the character code and is discarded;
561 any other non-digit terminates the character code and is then used as input."))
537 (and prompt (display-message 'prompt (format "%s-" prompt))) 562 (and prompt (display-message 'prompt (format "%s-" prompt)))
538 (setq event (next-command-event) 563 (setq event (next-command-event)
539 char (or (event-to-character event nil nil t) 564 char (or (event-to-character event nil nil t)
540 (signal 'error 565 (signal 'error
541 (list "key read cannot be inserted in a buffer" 566 (list "key read cannot be inserted in a buffer"
542 event)))) 567 event))))
543 (if inhibit-quit (setq quit-flag nil))) 568 (if inhibit-quit (setq quit-flag nil)))
544 (cond ((<= ?0 char ?7) 569 ;; Translate TAB key into control-I ASCII character, and so on.
545 (setq code (+ (* code 8) (- char ?0)) 570 (and char
546 count (1+ count)) 571 (let ((translated (lookup-key function-key-map (vector char))))
547 (when prompt 572 (if (arrayp translated)
548 (display-message 'prompt 573 (setq char (aref translated 0)))))
549 (setq prompt (format "%s %c" prompt char))))) 574 (cond ((null char))
550 ((> count 0) 575 ((not (characterp char))
551 (setq unread-command-event event 576 (setq unread-command-events (list char)
552 done t)) 577 done t))
553 (t (setq code (char-int char) 578 ; ((/= (logand char ?\M-\^@) 0)
554 done t)))) 579 ; ;; Turn a meta-character into a character with the 0200 bit set.
555 (int-char code) 580 ; (setq code (logior (logand char (lognot ?\M-\^@)) 128)
556 ;; Turn a meta-character into a character with the 0200 bit set. 581 ; done t))
557 ; (logior (if (/= (logand code ?\M-\^@) 0) 128 0) 582 ((and (<= ?0 char) (< char (+ ?0 (min 10 read-quoted-char-radix))))
558 ; (logand 255 code)))) 583 (setq code (+ (* code read-quoted-char-radix) (- char ?0)))
559 )) 584 (and prompt (setq prompt (display-message 'prompt
585 (format "%s %c" prompt char)))))
586 ((and (<= ?a (downcase char))
587 (< (downcase char) (+ ?a -10 (min 26 read-quoted-char-radix))))
588 (setq code (+ (* code read-quoted-char-radix)
589 (+ 10 (- (downcase char) ?a))))
590 (and prompt (setq prompt (display-message 'prompt
591 (format "%s %c" prompt char)))))
592 ((and (not first) (eq char ?\C-m))
593 (setq done t))
594 ((not first)
595 (setq unread-command-events (list char)
596 done t))
597 (t (setq code char
598 done t)))
599 (setq first nil))
600 (int-to-char code)))
601
602 ;; in passwd.el.
603 ; (defun read-passwd (prompt &optional confirm default)
604 ; "Read a password, prompting with PROMPT. Echo `.' for each character typed.
605 ; End with RET, LFD, or ESC. DEL or C-h rubs out. C-u kills line.
606 ; Optional argument CONFIRM, if non-nil, then read it twice to make sure.
607 ; Optional DEFAULT is a default password to use instead of empty input."
608 ; (if confirm
609 ; (let (success)
610 ; (while (not success)
611 ; (let ((first (read-passwd prompt nil default))
612 ; (second (read-passwd "Confirm password: " nil default)))
613 ; (if (equal first second)
614 ; (progn
615 ; (and (arrayp second) (fillarray second ?\0))
616 ; (setq success first))
617 ; (and (arrayp first) (fillarray first ?\0))
618 ; (and (arrayp second) (fillarray second ?\0))
619 ; (message "Password not repeated accurately; please start over")
620 ; (sit-for 1))))
621 ; success)
622 ; (let ((pass nil)
623 ; (c 0)
624 ; (echo-keystrokes 0)
625 ; (cursor-in-echo-area t))
626 ; (while (progn (message "%s%s"
627 ; prompt
628 ; (make-string (length pass) ?.))
629 ; (setq c (read-char-exclusive nil t))
630 ; (and (/= c ?\r) (/= c ?\n) (/= c ?\e)))
631 ; (clear-this-command-keys)
632 ; (if (= c ?\C-u)
633 ; (progn
634 ; (and (arrayp pass) (fillarray pass ?\0))
635 ; (setq pass ""))
636 ; (if (and (/= c ?\b) (/= c ?\177))
637 ; (let* ((new-char (char-to-string c))
638 ; (new-pass (concat pass new-char)))
639 ; (and (arrayp pass) (fillarray pass ?\0))
640 ; (fillarray new-char ?\0)
641 ; (setq c ?\0)
642 ; (setq pass new-pass))
643 ; (if (> (length pass) 0)
644 ; (let ((new-pass (substring pass 0 -1)))
645 ; (and (arrayp pass) (fillarray pass ?\0))
646 ; (setq pass new-pass))))))
647 ; (message nil)
648 ; (or pass default ""))))
649
650 ;; aliased to redraw-modeline, a built-in.
651 ; (defun force-mode-line-update (&optional all)
652 ; "Force the mode-line of the current buffer to be redisplayed.
653 ; With optional non-nil ALL, force redisplay of all mode-lines."
654 ; (if all (save-excursion (set-buffer (other-buffer))))
655 ; (set-buffer-modified-p (buffer-modified-p)))
560 656
561 (defun momentary-string-display (string pos &optional exit-char message) 657 (defun momentary-string-display (string pos &optional exit-char message)
562 "Momentarily display STRING in the buffer at POS. 658 "Momentarily display STRING in the buffer at POS.
563 Display remains until next character is typed. 659 Display remains until next character is typed.
564 If the char is EXIT-CHAR (optional third arg, default is SPC) it is swallowed; 660 If the char is EXIT-CHAR (optional third arg, default is SPC) it is swallowed;
565 otherwise it is then available as input (as a command if nothing else). 661 otherwise it is then available as input (as a command if nothing else).
566 Display MESSAGE (optional fourth arg) in the echo area. 662 Display MESSAGE (optional fourth arg) in the echo area.
567 If MESSAGE is nil, instructions to type EXIT-CHAR are displayed there." 663 If MESSAGE is nil, instructions to type EXIT-CHAR are displayed there."
568 (or exit-char (setq exit-char ?\ )) 664 (or exit-char (setq exit-char ?\ ))
569 (let ((buffer-read-only nil) 665 (let ((inhibit-read-only t)
570 ;; Don't modify the undo list at all. 666 ;; Don't modify the undo list at all.
571 (buffer-undo-list t) 667 (buffer-undo-list t)
572 (modified (buffer-modified-p)) 668 (modified (buffer-modified-p))
573 (name buffer-file-name) 669 (name buffer-file-name)
574 insert-end) 670 insert-end)
578 (goto-char pos) 674 (goto-char pos)
579 ;; defeat file locking... don't try this at home, kids! 675 ;; defeat file locking... don't try this at home, kids!
580 (setq buffer-file-name nil) 676 (setq buffer-file-name nil)
581 (insert-before-markers (gettext string)) 677 (insert-before-markers (gettext string))
582 (setq insert-end (point)) 678 (setq insert-end (point))
583 ;; If the message end is off frame, recenter now. 679 ;; If the message end is off screen, recenter now.
584 (if (> (window-end) insert-end) 680 (if (< (window-end nil t) insert-end)
585 (recenter (/ (window-height) 2))) 681 (recenter (/ (window-height) 2)))
586 ;; If that pushed message start off the frame, 682 ;; If that pushed message start off the frame,
587 ;; scroll to start it at the top of the frame. 683 ;; scroll to start it at the top of the frame.
588 (move-to-window-line 0) 684 (move-to-window-line 0)
589 (if (> (point) pos) 685 (if (> (point) pos)
592 (recenter 0)))) 688 (recenter 0))))
593 (message (or message (gettext "Type %s to continue editing.")) 689 (message (or message (gettext "Type %s to continue editing."))
594 (single-key-description exit-char)) 690 (single-key-description exit-char))
595 (let ((event (save-excursion (next-command-event)))) 691 (let ((event (save-excursion (next-command-event))))
596 (or (eq (event-to-character event) exit-char) 692 (or (eq (event-to-character event) exit-char)
597 (setq unread-command-event event)))) 693 (setq unread-command-events (list event)))))
598 (if insert-end 694 (if insert-end
599 (save-excursion 695 (save-excursion
600 (delete-region pos insert-end))) 696 (delete-region pos insert-end)))
601 (setq buffer-file-name name) 697 (setq buffer-file-name name)
602 (set-buffer-modified-p modified)))) 698 (set-buffer-modified-p modified))))
603 699
700 ;; END SYNCHED WITH FSF 21.2.
701
604 ;;; cmdloop.el ends here 702 ;;; cmdloop.el ends here