diff --git a/hemlock/charmacs.lisp b/hemlock/charmacs.lisp index aaf6bde2fbfc0d42ed16fcbc6996092e0dd7f09c..d6a684d769cf670ea6b8a374e4091bfba7e968b9 100644 --- a/hemlock/charmacs.lisp +++ b/hemlock/charmacs.lisp @@ -32,14 +32,9 @@ ;;; is a reasonable read-syntax and print-representation for all ;;; characters a user might run across. - -;;; All the meaningful bit names in this implementation. -;;; -(defconstant all-bit-names '(:control :meta :super :hyper)) - - + ;;;; Stuff for the Syntax table functions (syntax) -;;; + (defconstant syntax-char-code-limit 128 "The highest char-code which a character argument to the syntax table functions may have.") @@ -88,89 +83,8 @@ `(char-upcase (the string-char ,ch))) -;;; Specal RT and Sun keys: - -(eval-when (compile load eval) - -(push (cons "DELETE" #\delete) lisp::char-name-alist) -(push (cons "ESCAPE" #\escape) lisp::char-name-alist) -(push (cons "F1" (code-char 1)) lisp::char-name-alist) -(push (cons "F2" (code-char 2)) lisp::char-name-alist) -(push (cons "F3" (code-char 3)) lisp::char-name-alist) -(push (cons "F4" (code-char 4)) lisp::char-name-alist) -(push (cons "F5" (code-char 5)) lisp::char-name-alist) -(push (cons "F6" (code-char 6)) lisp::char-name-alist) -(push (cons "F7" (code-char 7)) lisp::char-name-alist) -(push (cons "F8" (code-char 11)) lisp::char-name-alist) -(push (cons "F9" (code-char 12)) lisp::char-name-alist) -(push (cons "F10" (code-char 14)) lisp::char-name-alist) -(push (cons "F11" (code-char 17)) lisp::char-name-alist) -(push (cons "F12" (code-char 18)) lisp::char-name-alist) -(push (cons "LEFTARROW" (code-char 19)) lisp::char-name-alist) -(push (cons "RIGHTARROW" (code-char 20)) lisp::char-name-alist) -(push (cons "UPARROW" (code-char 22)) lisp::char-name-alist) -(push (cons "DOWNARROW" (code-char 23)) lisp::char-name-alist) -(push (cons "LEFTDOWN" (code-char 24)) lisp::char-name-alist) -(push (cons "MIDDLEDOWN" (code-char 25)) lisp::char-name-alist) -(push (cons "RIGHTDOWN" (code-char 128)) lisp::char-name-alist) -(push (cons "LEFTUP" (code-char 129)) lisp::char-name-alist) -(push (cons "MIDDLEUP" (code-char 130)) lisp::char-name-alist) -(push (cons "RIGHTUP" (code-char 131)) lisp::char-name-alist) -(push (cons "INSERT" (code-char 132)) lisp::char-name-alist) -(push (cons "PRINTSCREEN" (code-char 133)) lisp::char-name-alist) -(push (cons "PAUSE" (code-char 134)) lisp::char-name-alist) -(push (cons "HOME" (code-char 135)) lisp::char-name-alist) -(push (cons "END" (code-char 136)) lisp::char-name-alist) -(push (cons "PAGEUP" (code-char 137)) lisp::char-name-alist) -(push (cons "PAGEDOWN" (code-char 138)) lisp::char-name-alist) -(push (cons "NUMLOCK" (code-char 139)) lisp::char-name-alist) -(push (cons "F13" (code-char 140)) lisp::char-name-alist) -(push (cons "F14" (code-char 141)) lisp::char-name-alist) -(push (cons "F15" (code-char 142)) lisp::char-name-alist) -(push (cons "F16" (code-char 143)) lisp::char-name-alist) -(push (cons "F17" (code-char 144)) lisp::char-name-alist) -(push (cons "F18" (code-char 145)) lisp::char-name-alist) -(push (cons "F19" (code-char 146)) lisp::char-name-alist) -(push (cons "F20" (code-char 147)) lisp::char-name-alist) -(push (cons "F21" (code-char 148)) lisp::char-name-alist) -(push (cons "F22" (code-char 149)) lisp::char-name-alist) -(push (cons "F23" (code-char 150)) lisp::char-name-alist) -(push (cons "F24" (code-char 151)) lisp::char-name-alist) -(push (cons "F25" (code-char 152)) lisp::char-name-alist) -(push (cons "F26" (code-char 153)) lisp::char-name-alist) -(push (cons "F27" (code-char 154)) lisp::char-name-alist) -(push (cons "F28" (code-char 155)) lisp::char-name-alist) -(push (cons "F29" (code-char 156)) lisp::char-name-alist) -(push (cons "F30" (code-char 157)) lisp::char-name-alist) -(push (cons "F31" (code-char 158)) lisp::char-name-alist) -(push (cons "F32" (code-char 159)) lisp::char-name-alist) -(push (cons "F33" (code-char 160)) lisp::char-name-alist) -(push (cons "F34" (code-char 161)) lisp::char-name-alist) -(push (cons "F35" (code-char 162)) lisp::char-name-alist) -;; ALTERNATE key on Sun keyboard. -(push (cons "BREAK" (code-char 163)) lisp::char-name-alist) - -) ;eval-when (compile load eval) - -;;; Stick them on the end so that they don't print this way. -;;; Use two separate EVAL-WHEN forms, so the #\f<13-35> characters can be -;;; read at this point. -;;; -(eval-when (compile load eval) -(setq lisp::char-name-alist - (append lisp::char-name-alist - '(("ENTER" . #\return) ("ACTION" . #\linefeed) - - ("L1" . #\F11) ("L2" . #\F12) ("L3" . #\F13) ("L4" . #\F14) - ("L5" . #\F15) ("L6" . #\F16) ("L7" . #\F17) ("L8" . #\F18) - ("L9" . #\F19) ("L10" . #\F20) - - ("R1" . #\F21) ("R2" . #\F22) ("R3" . #\F23) ("R4" . #\F24) - ("R5" . #\F25) ("R6" . #\F26) ("R7" . #\F27) ("R8" . #\F28) - ("R9" . #\F29) ("R10" . #\F30) ("R11" . #\F31) ("R12" . #\F32) - ("R13" . #\F33) ("R14" . #\F34) ("R15" . #\F35)))) -) ;eval-when - + +;;;; DO-ALPHA-CHARS. ;;; ALPHA-CHARS-LOOP loops from start-char through end-char binding var ;;; to the alphabetic characters and executing body. Note that the manual diff --git a/hemlock/diredcoms.lisp b/hemlock/diredcoms.lisp index a7ff58aec342124e8af2dca19554620c6ad5d858..97911dd011d8eaa0230162ae7d634c86a6e5a91f 100644 --- a/hemlock/diredcoms.lisp +++ b/hemlock/diredcoms.lisp @@ -64,13 +64,14 @@ " Type ? for help. ")) (defcommand "Dired" (p &optional directory) - "Prompt for a directory and edit it. If a dired for that directory already + "Prompts for a directory and edits it. If a dired for that directory already exists, go to that buffer, otherwise create one. With an argument, include UNIX dot files." - "Prompt for a directory and edit it. If a dired for that directory already + "Prompts for a directory and edits it. If a dired for that directory already exists, go to that buffer, otherwise create one. With an argument, include UNIX dot files." - (let ((info (if directory (value dired-information)))) + (let ((info (if (hemlock-bound-p 'dired-information) + (value dired-information)))) (dired-guts nil ;; Propagate dot-files property to subdirectory edits. (or (and info (dired-info-dot-files-p info)) @@ -320,6 +321,22 @@ (dired-command p (directory-namestring pathname)) (editor-error "No pathname associated with buffer.")))) +(defcommand "Dired Up Directory" (p) + "Invokes \"Dired\" on the directory up one level from the current Dired + buffer." + "Invokes \"Dired\" on the directory up one level from the current Dired + buffer." + (declare (ignore p)) + (unless (hemlock-bound-p 'dired-information) + (editor-error "Not in Dired buffer.")) + (let ((dirs (pathname-directory + (dired-info-pathname (value dired-information))))) + (declare (simple-vector dirs)) + (dired-command nil + (make-pathname + :device :absolute + :directory (subseq dirs 0 (1- (length dirs))))))) + ;;;; Dired misc. commands -- update, help, line motion. diff --git a/hemlock/echocoms.lisp b/hemlock/echocoms.lisp index 47ea1d66323bc9517e2ca0b2a0fe4ab664022e74..ae63b837d7f9cdd170899720b6625e9153408cc5 100644 --- a/hemlock/echocoms.lisp +++ b/hemlock/echocoms.lisp @@ -162,7 +162,8 @@ (:keyword (let ((point (current-point))) (unless (blank-after-p point) - (insert-character point *last-character-typed*))) + (insert-character point + (ext:key-event-char *last-key-event-typed*)))) (multiple-value-bind (prefix key value field ambig) (complete-string typein *parse-string-tables*) @@ -173,7 +174,9 @@ (subseq prefix 0 field) (concatenate 'string (subseq prefix 0 field) - (string *last-character-typed*))))) + (string + (ext:key-event-char + *last-key-event-typed*)))))) (insert-string (region-start *parse-input-region*) new-typein)))) (t (editor-error "Cannot complete input for this prompt."))))) diff --git a/hemlock/filecoms.lisp b/hemlock/filecoms.lisp index e7f76abe0ef9618248e0fef0327d5ac4fc03cbfe..8bd09342957b9a2772115f05722ddd720cd74185 100644 --- a/hemlock/filecoms.lisp +++ b/hemlock/filecoms.lisp @@ -429,7 +429,7 @@ (:no "Change to the buffer without reading the new version." t) - (#\R + (#\r "Read in the new version, clobbering the changes in the buffer." nil))) (t @@ -1032,6 +1032,26 @@ (editor-error "Cannot delete only window") (delete-window (next-window (current-window))))) +(defcommand "Go to One Window" (p) + "Deletes all windows leaving one with the \"Default Initial Window X\", + \"Default Initial Window Y\", \"Default Initial Window Width\", and + \"Default Initial Window Height\"." + "Deletes all windows leaving one with the \"Default Initial Window X\", + \"Default Initial Window Y\", \"Default Initial Window Width\", and + \"Default Initial Window Height\"." + (declare (ignore p)) + (let ((win (make-window (window-display-start (current-window)) + :ask-user t + :x (value default-initial-window-x) + :y (value default-initial-window-y) + :width (value default-initial-window-width) + :height (value default-initial-window-height)))) + (setf (current-window) win) + (dolist (w *window-list*) + (unless (or (eq w win) + (eq w *echo-area-window*)) + (delete-window w))))) + (defcommand "Line to Center of Window" (p) "Moves current line to the center of the window." "Moves current line to the center of the window." diff --git a/hemlock/fill.lisp b/hemlock/fill.lisp index 6ee99082d8f487cb19633ad5cf960fefef6710bc..a120c6adf3e684488d59d7855ffb72970217264a 100644 --- a/hemlock/fill.lisp +++ b/hemlock/fill.lisp @@ -125,7 +125,7 @@ ;; transparent key bindings are per binding instead of ;; per mode. (multiple-value-bind (command t-bindings) - (get-command #\linefeed :current) + (get-command #k"Linefeed" :current) (declare (ignore command)) ;command is this one, so don't invoke it (dolist (c t-bindings) (funcall *invoke-hook* c p))) (indent-new-line-command nil))) @@ -144,7 +144,7 @@ ;; transparent key bindings are per binding instead of ;; per mode. (multiple-value-bind (command t-bindings) - (get-command #\return :current) + (get-command #k"Return" :current) (declare (ignore command)) ;command is this one, so don't invoke it (dolist (c t-bindings) (funcall *invoke-hook* c p))) (new-line-command nil))) diff --git a/hemlock/input.lisp b/hemlock/input.lisp index 7dc4e34aecb4f0ce5bbaa59c353dd9a518399655..296430693c75997a8cf2f0925aef6b0f52133d21 100644 --- a/hemlock/input.lisp +++ b/hemlock/input.lisp @@ -223,7 +223,7 @@ ;;;; Editor input from windowing system. - +#| (defstruct (windowed-editor-input (:include editor-input (:get #'windowed-get-key-event) @@ -263,7 +263,7 @@ ;; Don't service anymore events if we just got some input. (return t)))) - +|# ;;;; Editor input from a tty. diff --git a/hemlock/lispmode.lisp b/hemlock/lispmode.lisp index 6e8a0d9d78f4f0c22a8e7d0dedb33837e666af69..d115cdc7515280af6f74a9ae90f4f7e89dde47f7 100644 --- a/hemlock/lispmode.lisp +++ b/hemlock/lispmode.lisp @@ -1165,6 +1165,32 @@ according to the FORWARDP flag." "Kill the previous Form." (forward-kill-form-command (- (or p 1)))) +(defcommand "Extract Form" (p) + "Replace the current containing list with the next form. The entire affected + area is pushed onto the kill ring. If an argument is supplied, that many + upward levels of list nesting is replaced by the next form." + "Replace the current containing list with the next form. The entire affected + area is pushed onto the kill ring. If an argument is supplied, that many + upward levels of list nesting is replaced by the next form." + (let ((point (current-point))) + (pre-command-parse-check point) + (with-mark ((form-start point :right-inserting) + (form-end point)) + (unless (form-offset form-end 1) (editor-error)) + (form-offset (move-mark form-start form-end) -1) + (with-mark ((containing-start form-start :left-inserting) + (containing-end form-end :left-inserting)) + (dotimes (i (or p 1)) + (unless (and (forward-up-list containing-end) + (backward-up-list containing-start)) + (editor-error))) + (let ((r (copy-region (region form-start form-end)))) + (ring-push (delete-and-save-region + (region containing-start containing-end)) + *kill-ring*) + (ninsert-region point r) + (move-mark point form-start)))))) + (defcommand "Extract List" (p) "Extract the current list. The current list replaces the surrounding list. The entire affected diff --git a/hemlock/morecoms.lisp b/hemlock/morecoms.lisp index 52b86e0b5991fa386fa2fc83749ed29011f9fc82..332eeee15489f9d5434d6b824840b3ad2ed98da2 100644 --- a/hemlock/morecoms.lisp +++ b/hemlock/morecoms.lisp @@ -171,7 +171,7 @@ "Prompt for stuff to do a bind-key." (declare (ignore p)) (multiple-value-call #'bind-key - (values (prompt-for-keyword + (values (prompt-for-keyword (list *command-names*) :prompt "Command to bind: " :help "Name of command to bind to a key.")) @@ -429,9 +429,8 @@ (last-key-event-cursorpos) (unless y (editor-error)) (cond ((< x 2) - (do ((ch (read-char-no-hang *editor-input*) - (read-char-no-hang *editor-input*))) - (ch) + (loop + (when (listen-editor-input *editor-input*) (return)) (scroll-window window -1) (redisplay) (editor-finish-output window))) @@ -448,9 +447,8 @@ (last-key-event-cursorpos) (unless y (editor-error)) (cond ((< x 2) - (do ((ch (read-char-no-hang *editor-input*) - (read-char-no-hang *editor-input*))) - (ch) + (loop + (when (listen-editor-input *editor-input*) (return)) (scroll-window window 1) (redisplay) (editor-finish-output window))) @@ -816,9 +814,44 @@ (declare (ignore p)) (setf (buffer-major-mode (current-buffer)) "Fundamental")) +;;; +;;; Text mode. +;;; + (defmode "Text" :major-p t) + (defcommand "Text Mode" (p) "Put the current buffer into \"Text\" mode." "Put the current buffer into \"Text\" mode." (declare (ignore p)) (setf (buffer-major-mode (current-buffer)) "Text")) + +;;; +;;; Caps-lock mode. +;;; + +(defmode "CAPS-LOCK") + +(defcommand "Caps Lock Mode" (p) + "Simulate having a CAPS LOCK key. Toggle CAPS-LOCK mode. Zero or a + negative argument turns it off, while a positive argument turns it + on." + "Simulate having a CAPS LOCK key. Toggle CAPS-LOCK mode. Zero or a + negative argument turns it off, while a positive argument turns it + on." + (setf (buffer-minor-mode (current-buffer) "CAPS-LOCK") + (if p + (plusp p) + (not (buffer-minor-mode (current-buffer) "CAPS-LOCK"))))) + +(defcommand "Self Insert Caps Lock" (p) + "Insert the last character typed, or the argument number of them. + If the last character was an alphabetic character, then insert its + capital form." + "Insert the last character typed, or the argument number of them. + If the last character was an alphabetic character, then insert its + capital form." + (let ((char (char-upcase (ext:key-event-char *last-key-event-typed*)))) + (if (and p (> p 1)) + (insert-string (current-point) (make-string p :initial-element char)) + (insert-character (current-point) char)))) diff --git a/hemlock/register.lisp b/hemlock/register.lisp index 7180dafb3e422d9326082ddb3ec3b224b77b3be9..bd11402617bea50192ba0ba4188769739c7a41cb 100644 --- a/hemlock/register.lisp +++ b/hemlock/register.lisp @@ -42,7 +42,7 @@ (setf (gethash ,name *registers*) ,value)))) (defun prompt-for-register (&optional (prompt "Register: ") must-exist) - (let ((reg-name (char-upcase (prompt-for-character :prompt prompt)))) + (let ((reg-name (prompt-for-key-event :prompt prompt))) (unless (or (not must-exist) (gethash reg-name *registers*)) (editor-error "Register ~A is empty." reg-name)) reg-name)) @@ -133,7 +133,7 @@ (with-pop-up-display (f :height (* 2 (register-count))) (do-registers (name val :sorted) (write-string "Reg " f) - (print-pretty-character name f) + (ext:print-pretty-key-event name f) (write-string ": " f) (etypecase val (mark diff --git a/hemlock/rompsite.lisp b/hemlock/rompsite.lisp index 9020d4a7059c3b63032a62448bd0765ad22b6bee..0bf967da99c1fda7c7b8b98dc8e320477805b904 100644 --- a/hemlock/rompsite.lisp +++ b/hemlock/rompsite.lisp @@ -18,13 +18,10 @@ (in-package "HEMLOCK-INTERNALS" :nicknames '("HI")) -(export '(show-mark editor-sleep text-character print-pretty-character - *input-transcript* *real-editor-input* input-waiting - fun-defined-from-pathname editor-describe-function pause-hemlock - store-cut-string fetch-cut-string schedule-event - remove-scheduled-event enter-window-autoraise directoryp - last-key-event-cursorpos merge-relative-pathnames *editor-input* - *last-character-typed* *character-history* +(export '(show-mark editor-sleep *input-transcript* fun-defined-from-pathname + editor-describe-function pause-hemlock store-cut-string + fetch-cut-string schedule-event remove-scheduled-event + enter-window-autoraise directoryp merge-relative-pathnames ;; ;; Export default-font to prevent a name conflict that occurs due to ;; the Hemlock variable "Default Font" defined in SITE-INIT below. @@ -53,11 +50,10 @@ ;;;; SITE-INIT. -;;; *character-history* is defined much later in this file, but it needs to -;;; be set in SITE-INIT, since MAKE-RING doesn't exist at load time for this -;;; file. +;;; *key-event-history* is defined in input.lisp, but it needs to be set in +;;; SITE-INIT, since MAKE-RING doesn't exist at load time for this file. ;;; -(proclaim '(special *character-history*)) +(proclaim '(special *key-event-history*)) ;;; SITE-INIT -- Internal ;;; @@ -128,7 +124,7 @@ a ruler in the bottom border of the window." :value t) - (setf *character-history* (make-ring 60)) + (setf *key-event-history* (make-ring 60)) nil) @@ -174,14 +170,6 @@ ;;;; I/O specials and initialization -(defvar *editor-input* nil - "Input stream to get unechoed unbuffered terminal input.") - -(defvar *real-editor-input* () - "The real editor input stream. Useful when we want to read from the - terminal when *editor-input* is rebound.") - - ;;; File descriptor for the terminal. ;;; (defvar *editor-file-descriptor*) @@ -232,6 +220,9 @@ "/afs/cs.cmu.edu/unix/rt_mach/omega/usr/misc/.lisp/lib/fonts/")) |# + +(proclaim '(special *editor-input* *real-editor-input*)) + ;;; INIT-RAW-IO -- Internal ;;; ;;; This function should be called whenever the editor is entered in a new @@ -241,7 +232,7 @@ (setf *editor-windowed-input* nil) (cond #+nil(display (setf *editor-windowed-input* (ext:open-clx-display display)) - (setf *editor-input* (make-editor-window-input-stream)) + (setf *editor-input* (make-windowed-editor-input)) (ext:carefully-add-font-paths *editor-windowed-input* lisp-fonts-pathnames) (setup-font-family *editor-windowed-input* @@ -253,7 +244,7 @@ ;; take care of this. ;; (setf *editor-file-descriptor* 0) - (setf *editor-input* (make-editor-tty-input-stream 0)))) + (setf *editor-input* (make-tty-editor-input 0)))) (setf *real-editor-input* *editor-input*) *editor-windowed-input*) @@ -499,7 +490,7 @@ (let ((win (bitmap-hunk-xwindow (window-hunk *current-window*))) (ewin (bitmap-hunk-xwindow (window-hunk *echo-area-window*)))) (cond (on (setf (xlib:window-priority ewin) :above) - (clear-input *editor-input*) + (clear-editor-input *editor-input*) (setf (xlib:window-priority win) :above)) (t (setf (xlib:window-priority ewin) :below) (setf (xlib:window-priority win) :below)))) @@ -519,425 +510,16 @@ -;;;; Current terminal character translation. - -(defvar *terminal-translation-table* (make-array 128)) - -;;; Converting ASCII control characters to Common Lisp control characters: -;;; ASCII control character codes are separated from the codes of the -;;; "non-controlified" characters by the code of atsign. The ASCII control -;;; character codes range from ^@ (0) through ^_ (one less than the code of -;;; space). We iterate over this range adding the ASCII code of atsign to -;;; get the "non-controlified" character code. With each of these, we turn -;;; the code into a Common Lisp character and set its :control bit. Certain -;;; ASCII control characters have to be translated to special Common Lisp -;;; characters outside of the loop. -;;; With the advent of Hemlock running under X, and all the key bindings -;;; changing, we also downcase each Common Lisp character (where normally -;;; control characters come in upcased) in an effort to obtain normal command -;;; bindings. Commands bound to uppercase modified characters will not be -;;; accessible to terminal interaction. -;;; -(let ((@-code (char-code #\@))) - (dotimes (i (char-code #\space)) - (setf (svref *terminal-translation-table* i) - (set-char-bit (char-downcase (code-char (+ i @-code))) :control t)))) -(setf (svref *terminal-translation-table* 9) #\tab) -(setf (svref *terminal-translation-table* 10) #\linefeed) -(setf (svref *terminal-translation-table* 13) #\return) -(setf (svref *terminal-translation-table* 27) #\alt) -(setf (svref *terminal-translation-table* 8) #\backspace) -;;; -;;; Other ASCII codes are exactly the same as the Common Lisp codes. -;;; -(do ((i (char-code #\space) (1+ i))) - ((= i 128)) - (setf (svref *terminal-translation-table* i) (code-char i))) - -;;; TRANSLATE-TTY-CHAR is our interface to be used in GET-EDITOR-INPUT. -;;; -(proclaim '(inline translate-tty-char)) -(defun translate-tty-char (char) - (svref *terminal-translation-table* char)) - - -(defconstant termcap-file "/etc/termcap") - -(defun cl-termcap-char (char) - (if (char-bit char :control) - (code-char (the fixnum - (- (the fixnum (char-code char)) - 64))) ;(char-code #\@) - (case char - (#\alt (code-char 27)) - (#\newline (code-char 10)) - (#\return (code-char 13)) - (#\tab (code-char 9)) - (#\backspace (code-char 8)) - (#\formfeed (code-char 12)) - (t char)))) - - - -;;;; Common editor input: stream def, event queue mngt, kbdmac waiting, -;;;; more prompt, input method macro. - -;;; This is the basic editor stream definition. More particular stream -;;; definitions below include this. -;;; -(defstruct (editor-input-stream - (:include stream) - (:print-function - (lambda (s stream d) - (declare (ignore s d)) - (write-string "#<Editor-Input stream>" stream))) - (:constructor make-editor-input-stream - (head &optional (tail head)))) - ;; - ;; FIFO queue of events on this stream. The queue always contains - ;; at least one one element, which is the character most recently read. - ;; If no event has been read, the event is a dummy with a NIL char. - head ; First key event in queue. - tail) ; Last event in queue. - - -;;; Key event queue. -;;; - -(defstruct (key-event - (:constructor make-key-event ())) - next ; Next queued event, or NIL if none. - hunk ; Screen hunk event was read from. - char ; Character read. - x ; X and Y character position of mouse cursor. - y - unread-p) - -(defvar *free-key-events* ()) - -(defun new-event (char x y hunk next &optional unread-p) - (let ((res (if *free-key-events* - (shiftf *free-key-events* (key-event-next *free-key-events*)) - (make-key-event)))) - (setf (key-event-char res) char) - (setf (key-event-x res) x) - (setf (key-event-y res) y) - (setf (key-event-hunk res) hunk) - (setf (key-event-next res) next) - (setf (key-event-unread-p res) unread-p) - res)) - -(defvar *last-character-typed* () - "This variable contains the last character typed to the command - interpreter.") - -;;; *character-history* is setup in SITE-INIT. -;;; -(defvar *character-history* nil - "This ring holds the last 60 characters read by the command interpreter.") - -(proclaim '(special *input-transcript*)) - -;;; DQ-EVENT is used in editor stream methods for popping off input. -;;; If there is an event not yet read in Stream, then pop the queue -;;; and return the character. If there is none, return NIL. -;;; -(defun dq-event (stream) - (without-interrupts - (let* ((head (editor-input-stream-head stream)) - (next (key-event-next head))) - (if next - (let ((char (key-event-char next))) - (setf (editor-input-stream-head stream) next) - (shiftf (key-event-next head) *free-key-events* head) - (ring-push char *character-history*) - (setq *last-character-typed* char) - (when *input-transcript* - (vector-push-extend char *input-transcript*)) - char))))) - -;;; Q-EVENT is used in low level input fetching routines to add input to the -;;; editor stream. -;;; -(defun q-event (stream char &optional x y hunk) - (without-interrupts - (let ((new (new-event char x y hunk nil)) - (tail (editor-input-stream-tail stream))) - (setf (key-event-next tail) new) - (setf (editor-input-stream-tail stream) new)))) - -(defun un-event (char stream) - (without-interrupts - (let* ((head (editor-input-stream-head stream)) - (next (key-event-next head)) - (new (new-event char (key-event-x head) (key-event-y head) - (key-event-hunk head) next t))) - (setf (key-event-next head) new) - (unless next (setf (editor-input-stream-tail stream) new))))) - - -;;; Keyboard macro hacks. -;;; - -(defvar *input-transcript* () - "If this variable is non-null then it should contain an adjustable vector - with a fill pointer into which all keyboard input will be pushed.") - -;;; INPUT-WAITING -- Internal -;;; -;;; An Evil hack that tells us whether there is an unread character on -;;; *editor-input*. Note that this is applied to the real *editor-input* -;;; rather than to a kbdmac stream. -;;; -(defun input-waiting () - "Returns true if there is a character which has been unread-char'ed - on *editor-input*. Used by the keyboard macro stuff." - (let ((next (key-event-next (editor-input-stream-head *real-editor-input*)))) - (and next (key-event-unread-p next)))) - - -;;; Random typeout hacks. -;;; - -(defun wait-for-more (stream) - (let ((ch (more-read-ch))) - (cond ((logical-char= ch :yes)) - ((or (logical-char= ch :do-all) - (logical-char= ch :exit)) - (setf (random-typeout-stream-no-prompt stream) t) - (random-typeout-cleanup stream)) - ((logical-char= ch :keep) - (setf (random-typeout-stream-no-prompt stream) t) - (maybe-keep-random-typeout-window stream) - (random-typeout-cleanup stream)) - ((logical-char= ch :no) - (random-typeout-cleanup stream) - (throw 'more-punt nil)) - (t - (unread-char ch *editor-input*) - (random-typeout-cleanup stream) - (throw 'more-punt nil))))) - -(proclaim '(special *more-prompt-action*)) - -(defun maybe-keep-random-typeout-window (stream) - (let* ((window (random-typeout-stream-window stream)) - (buffer (window-buffer window)) - (start (buffer-start-mark buffer))) - (when (typep (hi::device-hunk-device (hi::window-hunk window)) - 'hi::bitmap-device) - (let ((*more-prompt-action* :normal)) - (update-modeline-field buffer window :more-prompt) - (random-typeout-redisplay window)) - (buffer-start (buffer-point buffer)) - (unless (make-window start :window (make-xwindow-like-hwindow window)) - (editor-error "Could not create random typeout window."))))) - -(defun end-random-typeout (stream) - (let ((*more-prompt-action* :flush) - (window (random-typeout-stream-window stream))) - (update-modeline-field (window-buffer window) window :more-prompt) - (random-typeout-redisplay window)) - (unless (random-typeout-stream-no-prompt stream) - (let* ((ch (more-read-ch)) - (keep-p (logical-char= ch :keep))) - (when keep-p (maybe-keep-random-typeout-window stream)) - (random-typeout-cleanup stream) - (unless (or (logical-char= ch :do-all) - (logical-char= ch :exit) - (logical-char= ch :no) - (logical-char= ch :yes) - keep-p) - (unread-char ch *editor-input*))))) - -;;; MORE-READ-CH gets some input from the type of stream bound to -;;; *editor-input*. Need to loop over SERVE-EVENT since it returns on any kind -;;; of event (not necessarily a key or button event). -;;; -;;; Currently this does not work for keyboard macro streams! -;;; -(defun more-read-ch () - (clear-input *editor-input*) - (let ((ch (do ((ch (dq-event *editor-input*) (dq-event *editor-input*))) - (ch ch) - (system:serve-event)))) - (when (or (char= ch #\control-g) (char= ch #\control-\g)) - (beep) - (throw 'editor-top-level-catcher nil)) - ch)) - - -;;; Input method macro. -;;; - -(defvar *in-hemlock-stream-input-method* nil - "This keeps us from undefined nasties like re-entering Hemlock stream - input methods from input hooks and scheduled events.") - -(proclaim '(special *screen-image-trashed*)) - -;;; EDITOR-INPUT-METHOD-MACRO is used in EDITOR-TTY-IN and EDITOR-WINDOW-IN. -;;; Somewhat odd stuff goes on here because this is the place where Hemlock -;;; waits, so this is where we redisplay, check the time for scheduled -;;; events, etc. In the loop, we call the input hook when we get a character -;;; and leave the loop. If there isn't any input, invoke any scheduled -;;; events whose time is up. Unless SERVE-EVENT returns immediately and did -;;; something, (serve-event 0), call redisplay, note that we are going into -;;; a read wait, and call SERVE-EVENT with a wait or infinite timeout. Upon -;;; exiting the loop, turn off the read wait note and check for the abort -;;; character. Return the character we got. -;;; We bind an error condition handler here because the default Hemlock -;;; error handler goes into a little debugging prompt loop, but if we got -;;; an error in getting input, we should prompt the user using the input -;;; method (recursively even). -;;; -(eval-when (compile eval) -(defmacro editor-input-method-macro (&optional screen-image-trashed-concern) - `(handler-bind ((error #'(lambda (condition) - (let ((device (device-hunk-device - (window-hunk (current-window))))) - (funcall (device-exit device) device)) - (invoke-debugger condition)))) -; (when *in-hemlock-stream-input-method* -; (error "Entering Hemlock stream input method recursively!")) - (let ((*in-hemlock-stream-input-method* t) - (nrw-fun (device-note-read-wait - (device-hunk-device (window-hunk (current-window))))) - char) - (loop - (when (setf char (dq-event stream)) - (dolist (f (variable-value 'ed::input-hook)) (funcall f)) - (return)) - (invoke-scheduled-events) - (unless (system:serve-event 0) - (internal-redisplay) - ,@(if screen-image-trashed-concern - '((when *screen-image-trashed* (internal-redisplay)))) - (when nrw-fun (funcall nrw-fun t)) - (let ((wait (next-scheduled-event-wait))) - (if wait (system:serve-event wait) (system:serve-event))))) - (when nrw-fun (funcall nrw-fun nil)) - (when (and (or (char= char #\control-g) (char= char #\control-\g)) - eof-error-p) - (beep) - (throw 'editor-top-level-catcher nil)) - char))) -) ;eval-when - - - -;;;; Editor tty input streams. - -(defstruct (editor-tty-input-stream - (:include editor-input-stream - (:in #'editor-tty-in) - (:misc #'editor-tty-misc)) - (:print-function - (lambda (obj stream n) - (declare (ignore obj n)) - (write-string "#<Editor-Tty-Input stream>" stream))) - (:constructor make-editor-tty-input-stream - (fd &optional (head (make-key-event)) (tail head)))) - fd) - - -(defun editor-tty-misc (stream operation &optional arg1 arg2) - (declare (ignore arg2)) - (case operation - (:listen (cond ((key-event-next (editor-input-stream-head stream)) t) - ((editor-tty-listen stream) t) - (t nil))) - (:unread - (un-event arg1 stream)) - (:clear-input - (without-interrupts - (let* ((head (editor-input-stream-head stream)) - (next (key-event-next head))) - (when next - (setf (key-event-next head) nil) - (shiftf (key-event-next (editor-input-stream-tail stream)) - *free-key-events* next) - (setf (editor-input-stream-tail stream) head))))) - (:element-type 'character))) - - -(defun editor-tty-in (stream eof-error-p eof-value) - (declare (ignore eof-value)) - (editor-input-method-macro t)) +;;;; Line Wrap Char. +(defvar *line-wrap-char* #\! + "The character to be displayed to indicate wrapped lines.") -;;;; Editor window input streams. - -#| -(defstruct (editor-window-input-stream - (:include editor-input-stream - (:in #'editor-window-in) - (:misc #'editor-window-misc)) - (:print-function - (lambda (s stream d) - (declare (ignore s d)) - (write-string "#<Editor-Window-Input stream>" stream))) - (:constructor make-editor-window-input-stream - (&optional (head (make-key-event)) (tail head)))) - hunks) ; List of bitmap-hunks which input to this stream. - - -(defun editor-window-misc (stream operation &optional arg1 arg2) - (declare (ignore arg2)) - (case operation - (:listen - (loop (unless (system:serve-event 0) - ;; If nothing is pending, check the queued input. - (return (not (null (key-event-next - (editor-input-stream-head stream)))))) - (when (key-event-next (editor-input-stream-head stream)) - ;; Don't service anymore events if we just got some input. - (return t)))) - (:unread - (un-event arg1 stream)) - (:clear-input - (loop (unless (system:serve-event 0) (return))) - (without-interrupts - (let* ((head (editor-input-stream-head stream)) - (next (key-event-next head))) - (when next - (setf (key-event-next head) nil) - (shiftf (key-event-next (editor-input-stream-tail stream)) - *free-key-events* next) - (setf (editor-input-stream-tail stream) head))))) - (:element-type 'character))) - - -(defun editor-window-in (stream eof-error-p eof-value) - (declare (ignore eof-value)) - (editor-input-method-macro)) +;;;; Current terminal character translation. -|# +(defconstant termcap-file "/etc/termcap") -;;; LAST-KEY-EVENT-CURSORPOS -- Public -;;; -;;; Just look up the saved info in the last read key event. -;;; -(defun last-key-event-cursorpos () - "Return as values, the (X, Y) character position and window where the - last key event happened. If this cannot be determined, Nil is returned. - If in the modeline, return a Y position of NIL and the correct X and window. - Returns nil for terminal input." - (let* ((ev (editor-input-stream-head *real-editor-input*)) - (hunk (key-event-hunk ev)) - (window (and hunk (device-hunk-window hunk)))) - (when window - (values (key-event-x ev) (key-event-y ev) window)))) - - -;;; Window-Input-Handler -- Internal -;;; -;;; This is the input-handler function for hunks that implement windows. -;;; It just queues the events on the *real-editor-input* stream. -;;; -(defun window-input-handler (hunk char x y) - (q-event *real-editor-input* char x y hunk)) ;;;; Event scheduling. @@ -1049,7 +631,7 @@ (defun editor-sleep (time) "Sleep for approximately Time seconds." - (unless (or (zerop time) (listen *editor-input*)) + (unless (or (zerop time) (listen-editor-input *editor-input*)) (internal-redisplay) (sleep-for-time time) nil)) @@ -1060,7 +642,8 @@ (end (+ (get-internal-real-time) (truncate (* time internal-time-units-per-second))))) (loop - (when (listen *editor-input*) (return)) + (when (listen-editor-input *editor-input*) + (return)) (let ((left (- end (get-internal-real-time)))) (unless (plusp left) (return nil)) (when nrw-fun (funcall nrw-fun t)) @@ -1087,7 +670,7 @@ result)) (defun tty-show-mark (window x y time) - (cond ((listen *editor-input*)) + (cond ((listen-editor-input *editor-input*)) (x (internal-redisplay) (let* ((hunk (window-hunk window)) (device (device-hunk-device hunk))) @@ -1100,7 +683,7 @@ #| (defun bitmap-show-mark (window x y time) - (cond ((listen *editor-input*)) + (cond ((listen-editor-input *editor-input*)) (x (let* ((hunk (window-hunk window)) (display (bitmap-device-display (device-hunk-device hunk)))) (internal-redisplay) @@ -1113,53 +696,6 @@ (t nil))) |# - -;;;; Funny character stuff. - -;;; TEXT-CHARACTER and PRINT-PRETTY-CHARACTER are documented Hemlock primitives. -;;; - -(defun text-character (char) - "Translate a character as read from *editor-input* into one suitable for - inserting into text. If this is not possible, nil is returned." - (cond ((or (char-bit char :meta) - (char-bit char :super) - (char-bit char :hyper)) - nil) - ((char= char #\return) #\newline) - ((char-bit char :control) - (let* ((nchar (char-upcase (make-char char))) - (code (char-code nchar))) - (if (<= 64 code 95) - (code-char (- code 64)) - nil))) - (t char))) - -(defun print-pretty-character (char stream) - "Prints char to stream suitably for documentation, data displays, etc. - Control, Meta, Super, and Hyper bits are shown as C-, M-, S-, and H-, - respectively. If the character is not a standard character other than - #\space or #\newline, and it has a name, then the name is printed." - (when (char-bit char :control) (write-string "C-" stream)) - (when (char-bit char :meta) (write-string "M-" stream)) - (when (char-bit char :super) (write-string "S-" stream)) - (when (char-bit char :hyper) (write-string "H-" stream)) - (let ((code (char-code char)) - (safe-char (make-char char))) - (if (<= (char-code #\!) code (char-code #\~)) - (write-char safe-char stream) - (let ((name (char-name (code-char code)))) - (cond (name (write-string (string-capitalize name) stream)) - ((< code (char-code #\space)) - (write-char #\^ stream) - (write-char (code-char (+ code (char-code #\@))) stream)) - (t - (write-char safe-char stream))))))) - -(defvar *line-wrap-char* #\! - "The character to be displayed to indicate wrapped lines.") - - ;;;; Function description and defined-from. @@ -1357,7 +893,7 @@ (loop (when (>= i len) (return t)) (q-event *real-editor-input* - (translate-tty-char (char-code (schar buf i)))) + (ext:char-key-event (schar buf i))) (incf i)))) ;;; This is used to get listening during smart redisplay to pick up input @@ -1371,7 +907,7 @@ (mach::with-trap-arg-block mach::int1 nc (dotimes (i listen-iterations-hack nil) (multiple-value-bind (val err) - (mach::Unix-ioctl (editor-tty-input-stream-fd stream) + (mach::Unix-ioctl (tty-editor-input-fd stream) mach::FIONREAD (lisp::alien-value-sap mach::int1)) diff --git a/hemlock/shell.lisp b/hemlock/shell.lisp index 8f8cb6580eaf4eacc43caad1181f90fa12a791bd..fc3af3f0bd48a8415388967452839031bdb28791 100644 --- a/hemlock/shell.lisp +++ b/hemlock/shell.lisp @@ -69,41 +69,104 @@ ;;;; Some Global Variables. (defhvar "Current Shell" - "The shell that \"Select Shell\" will zap you to.") + "The shell to which \"Select Shell\" goes." + :value nil) +(defhvar "Ask about Old Shells" + "When set (the default), Hemlock prompts for an existing shell buffer in + preference to making a new one when there is no \"Current Shell\"." + :value t) + (defhvar "Kill Process Confirm" - "When non-nil, ask the user whether he really wants to blow away the shell. ~ - Otherwise, just blow it away." - :value T) + "When set, Hemlock prompts for confirmation before killing a buffer's process." + :value t) (defhvar "Shell Utility" - "The shell command uses this as the default command line." + "The \"Shell\" command uses this as the default command line." :value "/bin/csh") (defhvar "Shell Utility Switches" - "This is list of strings that are the default command line arguments to the - utility in \"Shell Utility\"." - :value nil) + "This is a string containing the default command line arguments to the + utility in \"Shell Utility\". This is a string since the utility is + typically \"/bin/csh\", and this string can contain I/O redirection and + other shell directives." + :value "") -;;;; The Shell and New Shell Commands. +;;;; The Shell, New Shell, and Set Current Shell Commands. + +(defvar *shell-names* (make-string-table) + "A string-table of the string-name of all process buffers and corresponding + buffer structures.") + +(defcommand "Set Current Shell" (p) + "Sets the value of \"Current Shell\", which the \"Shell\" command uses." + "Sets the value of \"Current Shell\", which the \"Shell\" command uses." + (declare (ignore p)) + (set-current-shell)) + +;;; SET-CURRENT-SHELL -- Internal. +;;; +;;; This prompts for a known shell buffer to which it sets "Current Shell". +;;; It signals an error if there are none. +;;; +(defun set-current-shell () + (let ((old-buffer (value current-shell)) + (first-old-shell (do-strings (var val *shell-names* nil) + (declare (ignore var val)) + (return var)))) + (when (and (not old-buffer) (not first-old-shell)) + (editor-error "Nothing to set current shell to.")) + (let ((default-shell (if old-buffer + (buffer-name old-buffer) + first-old-shell))) + (multiple-value-bind + (new-buffer-name new-buffer) + (prompt-for-keyword (list *shell-names*) + :must-exist t + :default default-shell + :default-string default-shell + :prompt "Existing Shell: " + :help "Enter the name of an existing shell.") + (declare (ignore new-buffer-name)) + (setf (value current-shell) new-buffer))))) (defcommand "Shell" (p) - "If a shell buffer exists, pop to it. Otherwise creates a new one and pop to - it. With an argument, prompt for a command and buffer to execute it in." - "If a shell buffer exists, pop to it. Otherwise creates a new one and pop to - it. With an argument, prompt for a command and buffer to execute it in." - (let ((shell (value current-shell))) - (if shell (change-to-buffer shell) (make-new-shell p)))) - -(defcommand "New Shell" (p) - "Creates a new shell and puts you in it." - "Creates a new shell and puts you in it." - (make-new-shell p)) - -(defun make-new-shell (prompt-for-command-p - &optional (command-line (get-command-line) clp)) + "This spawns a shell in a buffer. If there already is a \"Current Shell\", + this goes to that buffer. If there is no \"Current Shell\", there are + shell buffers, and \"Ask about Old Shells\" is set, this prompts for one + of them, setting \"Current Shell\" to that shell. Supplying an argument + forces the creation of a new shell buffer." + "This spawns a shell in a buffer. If there already is a \"Current Shell\", + this goes to that buffer. If there is no \"Current Shell\", there are + shell buffers, and \"Ask about Old Shells\" is set, this prompts for one + of them, setting \"Current Shell\" to that shell. Supplying an argument + forces the creation of a new shell buffer." + (let ((shell (value current-shell)) + (no-shells-p (do-strings (var val *shell-names* t) + (declare (ignore var val)) + (return nil)))) + (cond (p (make-new-shell nil no-shells-p)) + (shell (change-to-buffer shell)) + ((and (value ask-about-old-shells) (not no-shells-p)) + (set-current-shell) + (change-to-buffer (value current-shell))) + (t (make-new-shell nil))))) + +(defcommand "Shell Command Line in Buffer" (p) + "Prompts the user for a process and a buffer in which to run the process." + "Prompts the user for a process and a buffer in which to run the process." + (declare (ignore p)) + (make-new-shell t)) + +;;; MAKE-NEW-SHELL -- Internal. +;;; +;;; This makes new shells for us dealing with prompting for various things and +;;; setting "Current Shell" according to user documentation. +;;; +(defun make-new-shell (prompt-for-command-p &optional (set-current-shell-p t) + (command-line (get-command-line) clp)) (let* ((command (or (and clp command-line) (if prompt-for-command-p (prompt-for-string @@ -127,6 +190,7 @@ (list #'(lambda (buffer) (when (eq (value current-shell) buffer) (setf (value current-shell) nil)) + (delete-string (buffer-name buffer) *shell-names*) (kill-process (variable-value 'process :buffer buffer))))))) (unless buffer @@ -145,8 +209,9 @@ (declare (ignore process)) (update-process-buffer buffer)) :input t :output t)) + (setf (getstring buffer-name *shell-names*) buffer) (update-process-buffer buffer) - (unless (value current-shell) + (when (and (not (value current-shell)) set-current-shell-p) (setf (value current-shell) buffer)) (change-to-buffer buffer))) @@ -218,7 +283,8 @@ (let ((process (variable-value 'process :buffer buffer))) (unless (ext:process-alive-p process) (ext:process-close process) - (setf (value current-shell) nil)))) + (when (eq (value current-shell) buffer) + (setf (value current-shell) nil))))) ;;;; Supporting Commands. diff --git a/hemlock/streams.lisp b/hemlock/streams.lisp index c719b9aad7834d1ca91f4c01f50988b2d8aadc18..efe2312f3f2b35eff9f35cc09e4c392553027327 100644 --- a/hemlock/streams.lisp +++ b/hemlock/streams.lisp @@ -262,52 +262,33 @@ ;;;; Stuff to support keyboard macros. -;;; Note that the buffers in these streams must be general vectors, because -;;; the characters may have bits. - (defstruct (kbdmac-stream - (:include stream - (:in #'kbdmac-in) - (:listen #'kbdmac-listen) - (:misc #'kbdmac-misc)) + (:include editor-input + (:get #'kbdmac-get) + (:unget #'kbdmac-unget) + (:listen #'kbdmac-listen)) (:constructor make-kbdmac-stream ())) - ;; - ;; The simple-vector that holds the characters. - buffer - ;; - ;; Index of the next character. - index) + buffer ; The simple-vector that holds the characters. + index) ; Index of the next character. -;;; Kbdmac-In -- Internal -;;; -;;; This is the input method for a kbdmac stream. It just grabs a character -;;; and returns it, bumping the index. -;;; -(defun kbdmac-in (stream eof-errorp eof-value) - (declare (ignore eof-errorp eof-value)) +(defun kbdmac-get (stream ignore-abort-attempts-p) + (declare (ignore ignore-abort-attempts-p)) (let ((index (kbdmac-stream-index stream))) - (prog1 (setq *last-character-typed* - (svref (kbdmac-stream-buffer stream) index)) - (setf (kbdmac-stream-index stream) (1+ index))))) + (setf (kbdmac-stream-index stream) (1+ index)) + (setq *last-key-event-typed* + (svref (kbdmac-stream-buffer stream) index)))) -;;; Kbdmac-Misc -- Internal -;;; -;;; This is the misc method for kbdmac streams. Since any character -;;; that might have been read is included in the simulated input, listen -;;; will always return T. -;;; -(defun kbdmac-misc (stream operation &optional arg1 arg2) - (declare (ignore arg1 arg2)) - (case operation - (:unread - (if (plusp (kbdmac-stream-index stream)) - (decf (kbdmac-stream-index stream)) - (error "Nothing to unread."))) - (:listen t) - (:element-type 'string-char)) +(defun kbdmac-unget (ignore stream) + (declare (ignore ignore)) + (if (plusp (kbdmac-stream-index stream)) + (decf (kbdmac-stream-index stream)) + (error "Nothing to unread."))) + +(defun kbdmac-listen (stream) + (declare (ignore stream)) t) -;;; Modify-Kbdmac-Stream -- Internal +;;; MODIFY-KBDMAC-STREAM -- Internal ;;; ;;; Bash the kbdmac-stream Stream so that it will return the Input. ;;; diff --git a/hemlock/struct.lisp b/hemlock/struct.lisp index 550ed0ca76a6bac45824824882600230070bf75d..56471736cc9726d8f9c0a4cfe6f147571a37d1d3 100644 --- a/hemlock/struct.lisp +++ b/hemlock/struct.lisp @@ -589,7 +589,7 @@ "Set the Last-Command-Type for use by the next command.") (defsetf prefix-argument %set-prefix-argument "Set the prefix argument for the next command.") -(defsetf logical-char= %set-logical-char= +(defsetf logical-key-event-p %set-logical-key-event-p "Change what Logical-Char= returns for the specified arguments.") (defsetf window-font %set-window-font "Change the font-object associated with a font-number in a window.") diff --git a/hemlock/tty-display.lisp b/hemlock/tty-display.lisp index 1473c85d57e968538ba2997a55b5e6a77eebc34c..a3dc628179a907ccd7f2d69f1042c30c6217f8d7 100644 --- a/hemlock/tty-display.lisp +++ b/hemlock/tty-display.lisp @@ -218,7 +218,8 @@ (let* ((dl-chars (dis-line-chars dl)) (dl-len (dis-line-length dl))) (declare (fixnum dl-len) (simple-string dl-chars)) - (when (listen *editor-input*) (throw 'redisplay-catcher :editor-input)) + (when (listen-editor-input *editor-input*) + (throw 'redisplay-catcher :editor-input)) (select-hunk hunk) (let* ((screen-image-line (si-line (tty-device-screen-image device) (+ *hunk-top-line* dl-pos))) @@ -711,7 +712,8 @@ (let* ((dl-chars (dis-line-chars dl)) (dl-len (dis-line-length dl))) (declare (fixnum dl-len) (simple-string dl-chars)) - (when (listen *editor-input*) (throw 'redisplay-catcher :editor-input)) + (when (listen-editor-input *editor-input*) + (throw 'redisplay-catcher :editor-input)) (select-hunk hunk) (let* ((screen-image-line (si-line (tty-device-screen-image device) (+ *hunk-top-line* dl-pos))) diff --git a/tools/hemcom.lisp b/tools/hemcom.lisp index 2093f8fb8580843737511973a81d618b631fbd64..55c55c333f71d485103ea46288ea1bd6349f21aa 100644 --- a/tools/hemcom.lisp +++ b/tools/hemcom.lisp @@ -36,27 +36,11 @@ (in-package "C") (export 'compile-from-stream) -(in-package "HI") - -;;; ### bootstrap hack... -(defmacro parse-forms ((decls-var forms-var forms) &body gorms) - "Parse-Forms (Decls-Var Forms-Var Forms) {Form}* - Binds Decls-Var to leading declarations off of Forms and Forms-Var - to what is left." - `(do ((,forms-var ,forms (cdr ,forms-var)) - (,decls-var ())) - ((or (atom ,forms-var) (atom (car ,forms-var)) - (not (eq (caar ,forms-var) 'declare))) - ,@gorms) - (push (car ,forms-var) ,decls-var))) - (in-package "USER") - (pushnew :command-bits *features*) (pushnew :buffered-lines *features*) - (with-compiler-log-file ("hem:lossage.log") (comf "code:globals" :always-once t) @@ -65,10 +49,18 @@ (comf "hem:struct-ed" :always-once t) (comf "hem:rompsite" :always-once t) (comf "hem:charmacs" :always-once t) -;; keytran and keytrandefs used to be in rompsite, but they are too big now. -;; They also need to go after charmacs due to the funny characters named. -;(comf "hem:keytran") -;(comf "hem:keytrandefs") +(comf "hem:key-event" :load t) +;;; +;;; This is necessary since all the #k uses in Hemlock will expand into +;;; EXT:MAKE-KEY-EVENT calls with keysyms and bits from the compiling Lisp, not +;;; for the Lisp new code will run in. This destroys the compiling Lisp with +;;; respect to running code with #k's compiled for it, but it causes the +;;; compilation to see new keysyms, modifiers, and CLX modifier maps correctly +;;; for the new system. +;;; +(ext::re-initialize-key-events) +(comf "hem:keysym-defs" :load t) +(comf "hem:input.lisp") (comf "hem:macros" :always-once t) (comf "hem:line" :always-once t) (comf "hem:ring")