From 08d066bdaa1227e7e22accfd990862b5a94a0806 Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Fri, 13 Jul 1990 15:15:13 +0000 Subject: [PATCH] *** empty log message *** --- hemlock/bindings.lisp | 1232 ++++++++++++++++++-------------------- hemlock/bit-screen.lisp | 4 +- hemlock/buffer.lisp | 4 +- hemlock/charmacs.lisp | 105 +--- hemlock/command.lisp | 44 +- hemlock/completion.lisp | 21 +- hemlock/diredcoms.lisp | 25 +- hemlock/doccoms.lisp | 66 +- hemlock/echo.lisp | 351 +++++------ hemlock/echocoms.lisp | 8 +- hemlock/filecoms.lisp | 28 +- hemlock/files.lisp | 2 + hemlock/fill.lisp | 7 +- hemlock/gosmacs.lisp | 18 +- hemlock/hemlock.log | 315 ++++++++++ hemlock/icom.lisp | 2 +- hemlock/interp.lisp | 364 +++++------ hemlock/kbdmac.lisp | 37 +- hemlock/lispmode.lisp | 27 + hemlock/macros.lisp | 86 +-- hemlock/main.lisp | 3 +- hemlock/mh.lisp | 14 +- hemlock/morecoms.lisp | 48 +- hemlock/overwrite.lisp | 2 +- hemlock/register.lisp | 5 +- hemlock/rompsite.lisp | 599 ++---------------- hemlock/scribe.lisp | 222 ++++--- hemlock/searchcoms.lisp | 82 +-- hemlock/shell.lisp | 117 +++- hemlock/spellcoms.lisp | 87 +-- hemlock/srccom.lisp | 4 +- hemlock/streams.lisp | 64 +- hemlock/struct.lisp | 5 +- hemlock/termcap.lisp | 62 +- hemlock/ts-buf.lisp | 18 +- hemlock/tty-display.lisp | 22 +- tools/hemcom.lisp | 255 ++++---- 37 files changed, 2119 insertions(+), 2236 deletions(-) diff --git a/hemlock/bindings.lisp b/hemlock/bindings.lisp index 4a0e72300..1d7089ceb 100644 --- a/hemlock/bindings.lisp +++ b/hemlock/bindings.lisp @@ -16,72 +16,15 @@ ;;;; Default key translations: -;;; This page first maps all uppercase characters with all modifier bit -;;; combinations to the equivalent lowercase letter. This saves many -;;; duplicated BIND-KEY forms and tends to support what users expect out of a -;;; BIND-KEY call. +;;; This page defines prefix characters that set specified modifier bits on +;;; the next character typed. ;;; -;;; Secondly, this page defines prefix characters that set specified modifier -;;; bits on the next character typed. -;;; - -;;; Case insensitivize: -;;; -(defun case-insensitivize (bits) - "Make key translations from all the lowercase characters with specified bits - to the corresponding uppercase characters." - (do-alpha-chars (lower :lower) - (setf (key-translation (make-char (char-upcase lower) bits)) - (make-char lower bits)))) - -(case-insensitivize 0) -(case-insensitivize 1) -(case-insensitivize 2) -(case-insensitivize 3) - -(case-insensitivize 8) -(case-insensitivize 9) -(case-insensitivize 10) -(case-insensitivize 11) - - -;;; Prefix characters: -;;; -(setf (key-translation #\escape) '(:bits :meta)) -(setf (key-translation #\control-z) '(:bits :control :meta)) -(setf (key-translation #\control-\z) '(:bits :control :meta)) -(setf (key-translation #\control-^) '(:bits :control)) -(setf (key-translation #\control-c) '(:bits :hyper)) -(setf (key-translation #\control-\c) '(:bits :hyper)) - - - -;;;; Void some key translations. - -;;; This page kills some key translations so we can make use of case sensitive -;;; bindings. These translations must be voided for each modifier bit -;;; combination we are interested in. Characters with nil translations, used -;;; in bindings for which the translation is desired, must be bound to both the -;;; lower and upper case characters separately. For examples, see "Delete Next -;;; Character" and "Previous Undeleted Message". -;;; - -(setf (key-translation #\control-meta-s) nil) -(setf (key-translation #\control-meta-a) nil) -(setf (key-translation #\control-meta-v) nil) -(setf (key-translation #\control-meta-f) nil) -(setf (key-translation #\control-meta-l) nil) -(setf (key-translation #\control-meta-c) nil) - -(setf (key-translation #\control-d) nil) -(setf (key-translation #\control-m) nil) - -(setf (key-translation #\meta-p) nil) - -(setf (key-translation #\D) nil) -(setf (key-translation #\U) nil) -(setf (key-translation #\R) nil) -(setf (key-translation #\C) nil) +(setf (key-translation #k"escape") '(:bits :meta)) +(setf (key-translation #k"control-z") '(:bits :control :meta)) +(setf (key-translation #k"control-Z") '(:bits :control :meta)) +(setf (key-translation #k"control-^") '(:bits :control)) +(setf (key-translation #k"control-c") '(:bits :hyper)) +(setf (key-translation #k"control-C") '(:bits :hyper)) @@ -89,234 +32,220 @@ ;;; Self insert letters: ;;; -(do-alpha-chars (upper :upper) - (bind-key "Self Insert" upper)) - -;;; Add these lowercase letters since we killed the uppercase translations -;;; on the previous page. -;;; -(bind-key "Self Insert" #\d) -(bind-key "Self Insert" #\u) -(bind-key "Self Insert" #\r) -(bind-key "Self Insert" #\c) - - -(bind-key "Beginning of Line" #\control-a) -(bind-key "Delete Next Character" #\control-\d) -(bind-key "Delete Next Character" #\control-d) -(bind-key "End of Line" #\control-e) -(bind-key "Forward Character" #\control-f) -(bind-key "Forward Character" #\rightarrow) -(bind-key "Backward Character" #\control-b) -(bind-key "Backward Character" #\leftarrow) -(bind-key "Kill Line" #\control-k) -(bind-key "Refresh Screen" #\control-l) -(bind-key "Next Line" #\control-n) -(bind-key "Next Line" #\downarrow) -(bind-key "Previous Line" #\control-p) -(bind-key "Previous Line" #\uparrow) -(bind-key "Query Replace" #\meta-%) -(bind-key "Reverse Incremental Search" #\control-r) -(bind-key "Incremental Search" #\control-s) -(bind-key "Forward Search" #\meta-s) -(bind-key "Reverse Search" #\meta-r) -(bind-key "Transpose Characters" #\control-t) -(bind-key "Universal Argument" #\control-u) -(bind-key "Scroll Window Down" #\control-v) -(bind-key "Scroll Window Up" #\meta-v) -(bind-key "Scroll Next Window Down" #\control-meta-\v) - -(bind-key "Scroll Next Window Up" #\control-meta-V) - -(bind-key "Help" #\home) -(bind-key "Help" #\control-_) -(bind-key "Describe Key" #\meta-?) - - -(bind-key "Here to Top of Window" #\leftdown) -(bind-key "Do Nothing" #\leftup) -(bind-key "Top Line to Here" #\rightdown) -(bind-key "Do Nothing" #\rightup) -(bind-key "Point to Here" #\middledown) -(bind-key "Point to Here" #\super-leftdown) -(bind-key "Generic Pointer Up" #\middleup) -(bind-key "Generic Pointer Up" #\super-leftup) -(bind-key "Do Nothing" #\super-rightup) -(bind-key "Insert Kill Buffer" #\super-rightdown) - - -(bind-key "Insert File" '#(#\control-x #\control-r)) -(bind-key "Save File" '#(#\control-x #\control-s)) -(bind-key "Visit File" '#(#\control-x #\control-v)) -(bind-key "Write File" '#(#\control-x #\control-w)) -(bind-key "Find File" '#(#\control-x #\control-f)) -(bind-key "Backup File" '#(#\control-x #\meta-b)) -(bind-key "Save All Files" '#(#\control-x #\control-\m)) -(bind-key "Save All Files" '#(#\control-x #\control-m)) -(bind-key "Save All Files" '#(#\control-x #\return)) -(bind-key "Save All Files and Exit" '#(#\control-x #\meta-z)) - -(bind-key "List Buffers" '#(#\control-x #\control-b)) -(bind-key "Buffer Not Modified" #\meta-~) -(bind-key "Check Buffer Modified" '#(#\control-x #\~)) -(bind-key "Select Buffer" '#(#\control-x #\b)) -(bind-key "Select Previous Buffer" #\control-meta-\l) -(bind-key "Circulate Buffers" #\control-meta-l) -(bind-key "Create Buffer" '#(#\control-x #\meta-b)) -(bind-key "Kill Buffer" '#(#\control-x #\k)) -(bind-key "Select Random Typeout Buffer" #\hyper-t) - -(bind-key "Next Window" '#(#\control-x #\n)) -(bind-key "Next Window" '#(#\control-x #\o)) -(bind-key "Previous Window" '#(#\control-x #\p)) -(bind-key "Split Window" '#(#\control-x #\2)) -(bind-key "New Window" '#(#\control-x #\control-n)) -(bind-key "Delete Window" '#(#\control-x #\d)) -(bind-key "Delete Window" '#(#\control-x #\D)) -(bind-key "Delete Next Window" '#(#\control-x #\1)) -(bind-key "Line to Top of Window" #\meta-!) -(bind-key "Line to Center of Window" #\meta-\#) -(bind-key "Top of Window" #\meta-\,) -(bind-key "Bottom of Window" #\meta-\.) - -(bind-key "Exit Hemlock" '#(#\control-x #\control-z)) -(bind-key "Exit Hemlock" '#(#\control-x #\control-\z)) -(bind-key "Exit Recursive Edit" #\control-meta-z) -(bind-key "Abort Recursive Edit" #\control-]) - -(bind-key "Delete Previous Character" #\Delete) -(bind-key "Delete Previous Character" #\Backspace) -(bind-key "Kill Next Word" #\meta-d) -(bind-key "Kill Previous Word" #\meta-delete) -(bind-key "Kill Previous Word" #\meta-backspace) -(bind-key "Exchange Point and Mark" '#(#\control-x #\control-x)) -(bind-key "Mark Whole Buffer" '#(#\control-x #\h)) -(bind-key "Set/Pop Mark" #\control-@) -(bind-key "Set/Pop Mark" #\control-space) -(bind-key "Pop and Goto Mark" #\meta-space) -(bind-key "Pop and Goto Mark" #\meta-@) -(bind-key "Pop Mark" #\control-meta-space) ;#\c-m-@ is "Mark Form". -(bind-key "Kill Region" #\control-w) -(bind-key "Save Region" #\meta-w) -(bind-key "Un-Kill" #\control-y) -(bind-key "Rotate Kill Ring" #\meta-y) - -(bind-key "Forward Word" #\meta-f) -(bind-key "Backward Word" #\meta-b) - -(bind-key "Forward Paragraph" #\meta-]) -(bind-key "Forward Sentence" #\meta-e) -(bind-key "Backward Paragraph" #\meta-[) -(bind-key "Backward Sentence" #\meta-a) - -(bind-key "Mark Paragraph" #\meta-h) - -(bind-key "Forward Kill Sentence" #\meta-k) -(bind-key "Backward Kill Sentence" '#(#\control-x #\delete)) -(bind-key "Backward Kill Sentence" '#(#\control-x #\backspace)) - -(bind-key "Beginning of Buffer" #\meta-<) -(bind-key "End of Buffer" #\meta->) -(bind-key "Mark to Beginning of Buffer" #\control-<) -(bind-key "Mark to End of Buffer" #\control->) - -(bind-key "Extended Command" #\meta-x) - -(bind-key "Uppercase Word" '#\meta-u) -(bind-key "Lowercase Word" '#\meta-l) -(bind-key "Capitalize Word" '#\meta-c) - -(bind-key "Previous Page" '#(#\control-x #\[)) -(bind-key "Next Page" '#(#\control-x #\])) -(bind-key "Mark Page" '#(#\control-x #\control-p)) -(bind-key "Count Lines Page" '#(#\control-x #\l)) +(do-alpha-key-events (key-event :both) + (bind-key "Self Insert" key-event)) + +(bind-key "Beginning of Line" #k"control-a") +(bind-key "Delete Next Character" #k"control-d") +(bind-key "End of Line" #k"control-e") +(bind-key "Forward Character" #k"control-f") +(bind-key "Forward Character" #k"rightarrow") +(bind-key "Backward Character" #k"control-b") +(bind-key "Backward Character" #k"leftarrow") +(bind-key "Kill Line" #k"control-k") +(bind-key "Refresh Screen" #k"control-l") +(bind-key "Next Line" #k"control-n") +(bind-key "Next Line" #k"downarrow") +(bind-key "Previous Line" #k"control-p") +(bind-key "Previous Line" #k"uparrow") +(bind-key "Query Replace" #k"meta-%") +(bind-key "Reverse Incremental Search" #k"control-r") +(bind-key "Incremental Search" #k"control-s") +(bind-key "Forward Search" #k"meta-s") +(bind-key "Reverse Search" #k"meta-r") +(bind-key "Transpose Characters" #k"control-t") +(bind-key "Universal Argument" #k"control-u") +(bind-key "Scroll Window Down" #k"control-v") +(bind-key "Scroll Window Up" #k"meta-v") +(bind-key "Scroll Next Window Down" #k"control-meta-v") +(bind-key "Scroll Next Window Up" #k"control-meta-V") + +(bind-key "Help" #k"home") +(bind-key "Help" #k"control-_") +(bind-key "Describe Key" #k"meta-?") + + +(bind-key "Here to Top of Window" #k"leftdown") +(bind-key "Do Nothing" #k"leftup") +(bind-key "Top Line to Here" #k"rightdown") +(bind-key "Do Nothing" #k"rightup") +(bind-key "Point to Here" #k"middledown") +(bind-key "Point to Here" #k"super-leftdown") +(bind-key "Generic Pointer Up" #k"middleup") +(bind-key "Generic Pointer Up" #k"super-leftup") +(bind-key "Do Nothing" #k"super-rightup") +(bind-key "Insert Kill Buffer" #k"super-rightdown") + + +(bind-key "Insert File" #k"control-x control-r") +(bind-key "Save File" #k"control-x control-s") +(bind-key "Visit File" #k"control-x control-v") +(bind-key "Write File" #k"control-x control-w") +(bind-key "Find File" #k"control-x control-f") +(bind-key "Backup File" #k"control-x meta-b") +(bind-key "Save All Files" #k"control-x control-m") +(bind-key "Save All Files" #k"control-x return") +(bind-key "Save All Files and Exit" #k"control-x meta-z") + +(bind-key "List Buffers" #k"control-x control-b") +(bind-key "Buffer Not Modified" #k"meta-~") +(bind-key "Check Buffer Modified" #k"control-x ~") +(bind-key "Select Buffer" #k"control-x b") +(bind-key "Select Previous Buffer" #k"control-meta-l") +(bind-key "Circulate Buffers" #k"control-meta-L") +(bind-key "Create Buffer" #k"control-x meta-b") +(bind-key "Kill Buffer" #k"control-x k") +(bind-key "Select Random Typeout Buffer" #k"hyper-t") + +(bind-key "Next Window" #k"control-x n") +(bind-key "Next Window" #k"control-x o") +(bind-key "Previous Window" #k"control-x p") +(bind-key "Split Window" #k"control-x 2") +(bind-key "New Window" #k"control-x control-n") +(bind-key "Delete Window" #k"control-x d") +(bind-key "Delete Next Window" #k"control-x 1") +(bind-key "Line to Top of Window" #k"meta-!") +(bind-key "Line to Center of Window" #k"meta-#") +(bind-key "Top of Window" #k"meta-,") +(bind-key "Bottom of Window" #k"meta-.") + +(bind-key "Exit Hemlock" #k"control-x control-z") +(bind-key "Exit Recursive Edit" #k"control-meta-z") +(bind-key "Abort Recursive Edit" #k"control-]") + +(bind-key "Delete Previous Character" #k"delete") +(bind-key "Delete Previous Character" #k"backspace") +(bind-key "Kill Next Word" #k"meta-d") +(bind-key "Kill Previous Word" #k"meta-delete") +(bind-key "Kill Previous Word" #k"meta-backspace") +(bind-key "Exchange Point and Mark" #k"control-x control-x") +(bind-key "Mark Whole Buffer" #k"control-x h") +(bind-key "Set/Pop Mark" #k"control-@") +(bind-key "Set/Pop Mark" #k"control-space") +(bind-key "Pop and Goto Mark" #k"meta-space") +(bind-key "Pop and Goto Mark" #k"meta-@") +(bind-key "Pop Mark" #k"control-meta-space") ;#k"control-meta-@" = "Mark Form". +(bind-key "Kill Region" #k"control-w") +(bind-key "Save Region" #k"meta-w") +(bind-key "Un-Kill" #k"control-y") +(bind-key "Rotate Kill Ring" #k"meta-y") + +(bind-key "Forward Word" #k"meta-f") +(bind-key "Backward Word" #k"meta-b") + +(bind-key "Forward Paragraph" #k"meta-]") +(bind-key "Forward Sentence" #k"meta-e") +(bind-key "Backward Paragraph" #k"meta-[") +(bind-key "Backward Sentence" #k"meta-a") + +(bind-key "Mark Paragraph" #k"meta-h") + +(bind-key "Forward Kill Sentence" #k"meta-k") +(bind-key "Backward Kill Sentence" #k"control-x delete") +(bind-key "Backward Kill Sentence" #k"control-x backspace") + +(bind-key "Beginning of Buffer" #k"meta-\<") +(bind-key "End of Buffer" #k"meta-\>") +(bind-key "Mark to Beginning of Buffer" #k"control-\<") +(bind-key "Mark to End of Buffer" #k"control-\>") + +(bind-key "Extended Command" #k"meta-x") + +(bind-key "Uppercase Word" #k"meta-u") +(bind-key "Lowercase Word" #k"meta-l") +(bind-key "Capitalize Word" #k"meta-c") + +(bind-key "Previous Page" #k"control-x [")) +(bind-key "Next Page" #k"control-x ]")) +(bind-key "Mark Page" #k"control-x control-p") +(bind-key "Count Lines Page" #k"control-x l") ;;;; Argument Digit and Negative Argument. -(bind-key "Negative Argument" #\meta--) -(bind-key "Argument Digit" #\meta-0) -(bind-key "Argument Digit" #\meta-1) -(bind-key "Argument Digit" #\meta-2) -(bind-key "Argument Digit" #\meta-3) -(bind-key "Argument Digit" #\meta-4) -(bind-key "Argument Digit" #\meta-5) -(bind-key "Argument Digit" #\meta-6) -(bind-key "Argument Digit" #\meta-7) -(bind-key "Argument Digit" #\meta-8) -(bind-key "Argument Digit" #\meta-9) -(bind-key "Negative Argument" #\control--) -(bind-key "Argument Digit" #\control-0) -(bind-key "Argument Digit" #\control-1) -(bind-key "Argument Digit" #\control-2) -(bind-key "Argument Digit" #\control-3) -(bind-key "Argument Digit" #\control-4) -(bind-key "Argument Digit" #\control-5) -(bind-key "Argument Digit" #\control-6) -(bind-key "Argument Digit" #\control-7) -(bind-key "Argument Digit" #\control-8) -(bind-key "Argument Digit" #\control-9) -(bind-key "Negative Argument" #\control-meta--) -(bind-key "Argument Digit" #\control-meta-0) -(bind-key "Argument Digit" #\control-meta-1) -(bind-key "Argument Digit" #\control-meta-2) -(bind-key "Argument Digit" #\control-meta-3) -(bind-key "Argument Digit" #\control-meta-4) -(bind-key "Argument Digit" #\control-meta-5) -(bind-key "Argument Digit" #\control-meta-6) -(bind-key "Argument Digit" #\control-meta-7) -(bind-key "Argument Digit" #\control-meta-8) -(bind-key "Argument Digit" #\control-meta-9) +(bind-key "Negative Argument" #k"meta-\-") +(bind-key "Argument Digit" #k"meta-0") +(bind-key "Argument Digit" #k"meta-1") +(bind-key "Argument Digit" #k"meta-2") +(bind-key "Argument Digit" #k"meta-3") +(bind-key "Argument Digit" #k"meta-4") +(bind-key "Argument Digit" #k"meta-5") +(bind-key "Argument Digit" #k"meta-6") +(bind-key "Argument Digit" #k"meta-7") +(bind-key "Argument Digit" #k"meta-8") +(bind-key "Argument Digit" #k"meta-9") +(bind-key "Negative Argument" #k"control-\-") +(bind-key "Argument Digit" #k"control-0") +(bind-key "Argument Digit" #k"control-1") +(bind-key "Argument Digit" #k"control-2") +(bind-key "Argument Digit" #k"control-3") +(bind-key "Argument Digit" #k"control-4") +(bind-key "Argument Digit" #k"control-5") +(bind-key "Argument Digit" #k"control-6") +(bind-key "Argument Digit" #k"control-7") +(bind-key "Argument Digit" #k"control-8") +(bind-key "Argument Digit" #k"control-9") +(bind-key "Negative Argument" #k"control-meta-\-") +(bind-key "Argument Digit" #k"control-meta-0") +(bind-key "Argument Digit" #k"control-meta-1") +(bind-key "Argument Digit" #k"control-meta-2") +(bind-key "Argument Digit" #k"control-meta-3") +(bind-key "Argument Digit" #k"control-meta-4") +(bind-key "Argument Digit" #k"control-meta-5") +(bind-key "Argument Digit" #k"control-meta-6") +(bind-key "Argument Digit" #k"control-meta-7") +(bind-key "Argument Digit" #k"control-meta-8") +(bind-key "Argument Digit" #k"control-meta-9") ;;;; Self Insert and Quoted Insert. -(bind-key "Quoted Insert" #\control-q) - -(bind-key "Self Insert" " ") -(bind-key "Self Insert" "!") -(bind-key "Self Insert" "@") -(bind-key "Self Insert" "#") -(bind-key "Self Insert" "$") -(bind-key "Self Insert" "%") -(bind-key "Self Insert" "^") -(bind-key "Self Insert" "&") -(bind-key "Self Insert" "*") -(bind-key "Self Insert" "(") -(bind-key "Self Insert" ")") -(bind-key "Self Insert" "_") -(bind-key "Self Insert" "+") -(bind-key "Self Insert" "~") -(bind-key "Self Insert" "1") -(bind-key "Self Insert" "2") -(bind-key "Self Insert" "3") -(bind-key "Self Insert" "4") -(bind-key "Self Insert" "5") -(bind-key "Self Insert" "6") -(bind-key "Self Insert" "7") -(bind-key "Self Insert" "8") -(bind-key "Self Insert" "9") -(bind-key "Self Insert" "0") -(bind-key "Self Insert" "[") -(bind-key "Self Insert" "]") -(bind-key "Self Insert" "\\") -(bind-key "Self Insert" "|") -(bind-key "Self Insert" ":") -(bind-key "Self Insert" ";") -(bind-key "Self Insert" "\"") -(bind-key "Self Insert" "'") -(bind-key "Self Insert" "-") -(bind-key "Self Insert" "=") -(bind-key "Self Insert" "`") -(bind-key "Self Insert" "<") -(bind-key "Self Insert" ">") -(bind-key "Self Insert" ",") -(bind-key "Self Insert" ".") -(bind-key "Self Insert" "?") -(bind-key "Self Insert" "/") -(bind-key "Self Insert" "{") -(bind-key "Self Insert" "}") +(bind-key "Quoted Insert" #k"control-q") + +(bind-key "Self Insert" #k"space") +(bind-key "Self Insert" #k"!") +(bind-key "Self Insert" #k"@") +(bind-key "Self Insert" #k"#") +(bind-key "Self Insert" #k"$") +(bind-key "Self Insert" #k"%") +(bind-key "Self Insert" #k"^") +(bind-key "Self Insert" #k"&") +(bind-key "Self Insert" #k"*") +(bind-key "Self Insert" #k"(") +(bind-key "Self Insert" #k")") +(bind-key "Self Insert" #k"_") +(bind-key "Self Insert" #k"+") +(bind-key "Self Insert" #k"~") +(bind-key "Self Insert" #k"1") +(bind-key "Self Insert" #k"2") +(bind-key "Self Insert" #k"3") +(bind-key "Self Insert" #k"4") +(bind-key "Self Insert" #k"5") +(bind-key "Self Insert" #k"6") +(bind-key "Self Insert" #k"7") +(bind-key "Self Insert" #k"8") +(bind-key "Self Insert" #k"9") +(bind-key "Self Insert" #k"0") +(bind-key "Self Insert" #k"[") +(bind-key "Self Insert" #k"]") +(bind-key "Self Insert" #k"\\") +(bind-key "Self Insert" #k"|") +(bind-key "Self Insert" #k":") +(bind-key "Self Insert" #k";") +(bind-key "Self Insert" #k"\"") +(bind-key "Self Insert" #k"'") +(bind-key "Self Insert" #k"\-") +(bind-key "Self Insert" #k"=") +(bind-key "Self Insert" #k"`") +(bind-key "Self Insert" #k"\<") +(bind-key "Self Insert" #k"\>") +(bind-key "Self Insert" #k",") +(bind-key "Self Insert" #k".") +(bind-key "Self Insert" #k"?") +(bind-key "Self Insert" #k"/") +(bind-key "Self Insert" #k"{") +(bind-key "Self Insert" #k"}") @@ -324,304 +253,299 @@ ;;; Basic echo-area commands. ;;; -(bind-key "Help on Parse" #\home :mode "Echo Area") -(bind-key "Help on Parse" #\control-_ :mode "Echo Area") +(bind-key "Help on Parse" #k"home" :mode "Echo Area") +(bind-key "Help on Parse" #k"control-_" :mode "Echo Area") -(bind-key "Complete Keyword" #\escape :mode "Echo Area") -(bind-key "Complete Field" #\space :mode "Echo Area") -(bind-key "Confirm Parse" #\return :mode "Echo Area") +(bind-key "Complete Keyword" #k"escape" :mode "Echo Area") +(bind-key "Complete Field" #k"space" :mode "Echo Area") +(bind-key "Confirm Parse" #k"return" :mode "Echo Area") ;;; Rebind some standard commands to behave better. ;;; -(bind-key "Kill Parse" #\control-u :mode "Echo Area") -(bind-key "Insert Parse Default" #\control-i :mode "Echo Area") -(bind-key "Insert Parse Default" #\tab :mode "Echo Area") -(bind-key "Echo Area Delete Previous Character" #\delete :mode "Echo Area") -(bind-key "Echo Area Delete Previous Character" #\backspace :mode "Echo Area") -(bind-key "Echo Area Kill Previous Word" #\meta-h :mode "Echo Area") -(bind-key "Echo Area Kill Previous Word" #\meta-delete :mode "Echo Area") -(bind-key "Echo Area Kill Previous Word" #\meta-backspace :mode "Echo Area") -(bind-key "Echo Area Kill Previous Word" #\control-w :mode "Echo Area") -(bind-key "Beginning of Parse" #\control-a :mode "Echo Area") -(bind-key "Beginning of Parse" #\meta-< :mode "Echo Area") -(bind-key "Echo Area Backward Character" #\control-b :mode "Echo Area") -(bind-key "Echo Area Backward Word" #\meta-b :mode "Echo Area") -(bind-key "Next Parse" #\control-n :mode "Echo Area") -(bind-key "Previous Parse" #\control-p :mode "Echo Area") - -;;; Nuke some dangerous standard bindings. +(bind-key "Kill Parse" #k"control-u" :mode "Echo Area") +(bind-key "Insert Parse Default" #k"control-i" :mode "Echo Area") +(bind-key "Insert Parse Default" #k"tab" :mode "Echo Area") +(bind-key "Echo Area Delete Previous Character" #k"delete" :mode "Echo Area") +(bind-key "Echo Area Delete Previous Character" #k"backspace" :mode "Echo Area") +(bind-key "Echo Area Kill Previous Word" #k"meta-h" :mode "Echo Area") +(bind-key "Echo Area Kill Previous Word" #k"meta-delete" :mode "Echo Area") +(bind-key "Echo Area Kill Previous Word" #k"meta-backspace" :mode "Echo Area") +(bind-key "Echo Area Kill Previous Word" #k"control-w" :mode "Echo Area") +(bind-key "Beginning of Parse" #k"control-a" :mode "Echo Area") +(bind-key "Beginning of Parse" #k"meta-\<" :mode "Echo Area") +(bind-key "Echo Area Backward Character" #k"control-b" :mode "Echo Area") +(bind-key "Echo Area Backward Word" #k"meta-b" :mode "Echo Area") +(bind-key "Next Parse" #k"control-n" :mode "Echo Area") +(bind-key "Previous Parse" #k"control-p" :mode "Echo Area") + +;;; Remove some dangerous standard bindings. ;;; -(bind-key "Illegal" #\control-x :mode "Echo Area") -(bind-key "Illegal" #\control-meta-c :mode "Echo Area") -(bind-key "Illegal" #\control-meta-\c :mode "Echo Area") -(bind-key "Illegal" #\control-meta-l :mode "Echo Area") -(bind-key "Illegal" #\control-meta-\l :mode "Echo Area") -(bind-key "Illegal" #\meta-x :mode "Echo Area") -(bind-key "Illegal" #\control-s :mode "Echo Area") -(bind-key "Illegal" #\control-r :mode "Echo Area") -(bind-key "Illegal" #\middledown :mode "Echo Area") -(bind-key "Do Nothing" #\middleup :mode "Echo Area") -(bind-key "Illegal" #\super-leftdown :mode "Echo Area") -(bind-key "Do Nothing" #\super-leftup :mode "Echo Area") -(bind-key "Illegal" #\super-rightdown :mode "Echo Area") -(bind-key "Do Nothing" #\super-rightup :mode "Echo Area") +(bind-key "Illegal" #k"control-x" :mode "Echo Area") +(bind-key "Illegal" #k"control-meta-c" :mode "Echo Area") +(bind-key "Illegal" #k"control-meta-l" :mode "Echo Area") +(bind-key "Illegal" #k"meta-x" :mode "Echo Area") +(bind-key "Illegal" #k"control-s" :mode "Echo Area") +(bind-key "Illegal" #k"control-r" :mode "Echo Area") +(bind-key "Illegal" #k"hyper-t" :mode "Echo Area") +(bind-key "Illegal" #k"middledown" :mode "Echo Area") +(bind-key "Do Nothing" #k"middleup" :mode "Echo Area") +(bind-key "Illegal" #k"super-leftdown" :mode "Echo Area") +(bind-key "Do Nothing" #k"super-leftup" :mode "Echo Area") +(bind-key "Illegal" #k"super-rightdown" :mode "Echo Area") +(bind-key "Do Nothing" #k"super-rightup" :mode "Echo Area") ;;;; Eval and Editor Modes. -(bind-key "Confirm Eval Input" #\return :mode "Eval") -(bind-key "Previous Interactive Input" #\meta-\p :mode "Eval") -(bind-key "Search Previous Interactive Input" #\meta-p :mode "Eval") -(bind-key "Next Interactive Input" #\meta-n :mode "Eval") -(bind-key "Kill Interactive Input" #\meta-i :mode "Eval") -(bind-key "Abort Eval Input" #\control-meta-i :mode "Eval") -(bind-key "Interactive Beginning of Line" #\control-a :mode "Eval") -(bind-key "Reenter Interactive Input" #\control-return :mode "Eval") - -(bind-key "Editor Evaluate Expression" #\control-meta-escape) -(bind-key "Editor Evaluate Expression" #\meta-escape :mode "Editor") -(bind-key "Editor Evaluate Defun" '#(#\control-x #\control-e) :mode "Editor") -(bind-key "Editor Compile Defun" '#(#\control-x #\control-c) :mode "Editor") -(bind-key "Editor Compile Defun" '#(#\control-x #\control-\c) :mode "Editor") -(bind-key "Editor Macroexpand Expression" #\control-M :mode "Editor") -(bind-key "Editor Describe Function Call" #\control-meta-A :mode "Editor") -(bind-key "Editor Describe Symbol" #\control-meta-S :mode "Editor") +(bind-key "Confirm Eval Input" #k"return" :mode "Eval") +(bind-key "Previous Interactive Input" #k"meta-p" :mode "Eval") +(bind-key "Search Previous Interactive Input" #k"meta-P" :mode "Eval") +(bind-key "Next Interactive Input" #k"meta-n" :mode "Eval") +(bind-key "Kill Interactive Input" #k"meta-i" :mode "Eval") +(bind-key "Abort Eval Input" #k"control-meta-i" :mode "Eval") +(bind-key "Interactive Beginning of Line" #k"control-a" :mode "Eval") +(bind-key "Reenter Interactive Input" #k"control-return" :mode "Eval") + +(bind-key "Editor Evaluate Expression" #k"control-meta-escape") +(bind-key "Editor Evaluate Expression" #k"meta-escape" :mode "Editor") +(bind-key "Editor Evaluate Defun" #k"control-x control-e" :mode "Editor") +(bind-key "Editor Compile Defun" #k"control-x control-c" :mode "Editor") +(bind-key "Editor Compile Defun" #k"control-x control-C" :mode "Editor") +(bind-key "Editor Macroexpand Expression" #k"control-m" :mode "Editor") +(bind-key "Editor Describe Function Call" #k"control-meta-A" :mode "Editor") +(bind-key "Editor Describe Symbol" #k"control-meta-S" :mode "Editor") ;;;; Typescript. -(bind-key "Confirm Typescript Input" #\return :mode "Typescript") -(bind-key "Interactive Beginning of Line" #\control-a :mode "Typescript") -(bind-key "Kill Interactive Input" #\meta-i :mode "Typescript") -;(bind-key "Abort Typescript Input" #\control-meta-i :mode "Typescript") -(bind-key "Previous Interactive Input" #\meta-\p :mode "Typescript") -(bind-key "Search Previous Interactive Input" #\meta-p :mode "Typescript") -(bind-key "Next Interactive Input" #\meta-n :mode "Typescript") -(bind-key "Reenter Interactive Input" #\control-return :mode "Typescript") -(bind-key "Typescript Slave Break" #\hyper-b :mode "Typescript") -(bind-key "Typescript Slave to Top Level" #\hyper-g :mode "Typescript") -(bind-key "Select Slave" #\control-meta-\c) -(bind-key "Select Background" #\control-meta-C) +(bind-key "Confirm Typescript Input" #k"return" :mode "Typescript") +(bind-key "Interactive Beginning of Line" #k"control-a" :mode "Typescript") +(bind-key "Kill Interactive Input" #k"meta-i" :mode "Typescript") +(bind-key "Previous Interactive Input" #k"meta-p" :mode "Typescript") +(bind-key "Search Previous Interactive Input" #k"meta-P" :mode "Typescript") +(bind-key "Next Interactive Input" #k"meta-n" :mode "Typescript") +(bind-key "Reenter Interactive Input" #k"control-return" :mode "Typescript") +(bind-key "Typescript Slave Break" #k"hyper-b" :mode "Typescript") +(bind-key "Typescript Slave to Top Level" #k"hyper-g" :mode "Typescript") +(bind-key "Select Slave" #k"control-meta-\c") +(bind-key "Select Background" #k"control-meta-C") -(bind-key "Abort Operations" #\hyper-a) -(bind-key "List Operations" #\hyper-l) +(bind-key "Abort Operations" #k"hyper-a") +(bind-key "List Operations" #k"hyper-l") -(bind-key "Next Compiler Error" #\hyper-n) -(bind-key "Previous Compiler Error" #\hyper-p) +(bind-key "Next Compiler Error" #k"hyper-n") +(bind-key "Previous Compiler Error" #k"hyper-p") ;;;; Lisp (some). -(bind-key "Indent Form" #\control-meta-q) -(bind-key "Defindent" #\control-meta-\#) -(bind-key "Beginning of Defun" #\control-meta-[) -(bind-key "End of Defun" #\control-meta-]) -(bind-key "Beginning of Defun" #\control-meta-\a) -(bind-key "End of Defun" #\control-meta-e) -(bind-key "Forward Form" #\control-meta-\f) -(bind-key "Backward Form" #\control-meta-b) -(bind-key "Forward List" #\control-meta-n) -(bind-key "Backward List" #\control-meta-p) -(bind-key "Transpose Forms" #\control-meta-t) -(bind-key "Forward Kill Form" #\control-meta-k) -(bind-key "Backward Kill Form" #\control-meta-backspace) -(bind-key "Backward Kill Form" #\control-meta-delete) -(bind-key "Mark Form" #\control-meta-@) -(bind-key "Mark Defun" #\control-meta-h) -(bind-key "Insert ()" #\meta-\() -(bind-key "Move over )" #\meta-\)) -(bind-key "Backward Up List" #\control-meta-\() -(bind-key "Backward Up List" #\control-meta-u) -(bind-key "Forward Up List" #\control-meta-\)) -(bind-key "Down List" #\control-meta-d) -(bind-key "Extract List" #\control-meta-x) -(bind-key "Lisp Insert )" #\) :mode "Lisp") -(bind-key "Delete Previous Character Expanding Tabs" #\backspace :mode "Lisp") -(bind-key "Delete Previous Character Expanding Tabs" #\delete :mode "Lisp") - -(bind-key "Evaluate Expression" #\meta-escape) -(bind-key "Evaluate Defun" '#(#\control-x #\control-e)) -(bind-key "Compile Defun" '#(#\control-x #\control-c)) -(bind-key "Compile Defun" '#(#\control-x #\control-\c)) -(bind-key "Compile Buffer File" '#(#\control-x #\c)) -(bind-key "Compile Buffer File" '#(#\control-x #\C)) -(bind-key "Macroexpand Expression" #\control-M) - -(bind-key "Describe Function Call" #\control-meta-A) -(bind-key "Describe Symbol" #\control-meta-S) - -(bind-key "Goto Definition" #\control-meta-F) +(bind-key "Indent Form" #k"control-meta-q") +(bind-key "Defindent" #k"control-meta-#") +(bind-key "Beginning of Defun" #k"control-meta-[") +(bind-key "End of Defun" #k"control-meta-]") +(bind-key "Beginning of Defun" #k"control-meta-a") +(bind-key "End of Defun" #k"control-meta-e") +(bind-key "Forward Form" #k"control-meta-f") +(bind-key "Backward Form" #k"control-meta-b") +(bind-key "Forward List" #k"control-meta-n") +(bind-key "Backward List" #k"control-meta-p") +(bind-key "Transpose Forms" #k"control-meta-t") +(bind-key "Forward Kill Form" #k"control-meta-k") +(bind-key "Backward Kill Form" #k"control-meta-backspace") +(bind-key "Backward Kill Form" #k"control-meta-delete") +(bind-key "Mark Form" #k"control-meta-@") +(bind-key "Mark Defun" #k"control-meta-h") +(bind-key "Insert ()" #k"meta-(") +(bind-key "Move over )" #k"meta-)") +(bind-key "Backward Up List" #k"control-meta-(") +(bind-key "Backward Up List" #k"control-meta-u") +(bind-key "Forward Up List" #k"control-meta-)") +(bind-key "Down List" #k"control-meta-d") +(bind-key "Extract List" #k"control-meta-x") +(bind-key "Lisp Insert )" #k")" :mode "Lisp") +(bind-key "Delete Previous Character Expanding Tabs" #k"backspace" :mode "Lisp") +(bind-key "Delete Previous Character Expanding Tabs" #k"delete" :mode "Lisp") + +(bind-key "Evaluate Expression" #k"meta-escape") +(bind-key "Evaluate Defun" #k"control-x control-e") +(bind-key "Compile Defun" #k"control-x control-c") +(bind-key "Compile Buffer File" #k"control-x c") +(bind-key "Macroexpand Expression" #k"control-M") + +(bind-key "Describe Function Call" #k"control-meta-A") +(bind-key "Describe Symbol" #k"control-meta-S") + +(bind-key "Goto Definition" #k"control-meta-F") ;;;; More Miscellaneous bindings. -(bind-key "Open Line" #\Control-O) -(bind-key "New Line" #\return) - -(bind-key "Transpose Words" #\meta-t) -(bind-key "Transpose Lines" '#(#\control-x #\control-t)) -(bind-key "Transpose Regions" '#(#\control-x #\t)) - -(bind-key "Uppercase Region" '#(#\control-x #\control-u)) -(bind-key "Lowercase Region" '#(#\control-x #\control-l)) - -(bind-key "Delete Indentation" #\meta-^) -(bind-key "Delete Indentation" #\control-meta-^) -(bind-key "Delete Horizontal Space" #\meta-\\) -(bind-key "Delete Blank Lines" '#(#\control-x #\control-o) :global) -(bind-key "Just One Space" #\meta-\|) -(bind-key "Back to Indentation" #\meta-m) -(bind-key "Back to Indentation" #\control-meta-m) -(bind-key "Indent Rigidly" '#(#\control-x #\tab)) -(bind-key "Indent Rigidly" '#(#\control-x #\control-i)) - -(bind-key "Indent New Line" #\linefeed) -(bind-key "Indent" #\tab) -(bind-key "Indent" #\control-i) -(bind-key "Indent Region" #\control-meta-\\) -(bind-key "Quote Tab" #\meta-tab) - -(bind-key "Directory" '#(#\control-x #\control-\d)) -(bind-key "Verbose Directory" '#(#\control-x #\control-D)) - -(bind-key "Activate Region" '#(#\control-x #\control-@)) -(bind-key "Activate Region" '#(#\control-x #\control-space)) - -(bind-key "Save Position" '#(#\control-x #\s)) -(bind-key "Jump to Saved Position" '#(#\control-x #\j)) -(bind-key "Put Register" '#(#\control-x #\x)) -(bind-key "Get Register" '#(#\control-x #\g)) - -(bind-key "Delete Previous Character Expanding Tabs" #\backspace :mode "Pascal") -(bind-key "Delete Previous Character Expanding Tabs" #\delete :mode "Pascal") -(bind-key "Scribe Insert Bracket" #\) :mode "Pascal") -(bind-key "Scribe Insert Bracket" #\] :mode "Pascal") -(bind-key "Scribe Insert Bracket" #\} :mode "Pascal") +(bind-key "Open Line" #k"Control-o") +(bind-key "New Line" #k"return") + +(bind-key "Transpose Words" #k"meta-t") +(bind-key "Transpose Lines" #k"control-x control-t") +(bind-key "Transpose Regions" #k"control-x t")) + +(bind-key "Uppercase Region" #k"control-x control-u") +(bind-key "Lowercase Region" #k"control-x control-l") + +(bind-key "Delete Indentation" #k"meta-^") +(bind-key "Delete Indentation" #k"control-meta-^") +(bind-key "Delete Horizontal Space" #k"meta-\\") +(bind-key "Delete Blank Lines" #k"control-x control-o" :global) +(bind-key "Just One Space" #k"meta-\|") +(bind-key "Back to Indentation" #k"meta-m") +(bind-key "Back to Indentation" #k"control-meta-m") +(bind-key "Indent Rigidly" #k"control-x tab") +(bind-key "Indent Rigidly" #k"control-x control-i") + +(bind-key "Indent New Line" #k"linefeed") +(bind-key "Indent" #k"tab") +(bind-key "Indent" #k"control-i") +(bind-key "Indent Region" #k"control-meta-\\") +(bind-key "Quote Tab" #k"meta-tab") + +(bind-key "Directory" #k"control-x control-\d") +(bind-key "Verbose Directory" #k"control-x control-D") + +(bind-key "Activate Region" #k"control-x control-@") +(bind-key "Activate Region" #k"control-x control-space") + +(bind-key "Save Position" #k"control-x s") +(bind-key "Jump to Saved Position" #k"control-x j") +(bind-key "Put Register" #k"control-x x") +(bind-key "Get Register" #k"control-x g") + +(bind-key "Delete Previous Character Expanding Tabs" #k"backspace" + :mode "Pascal") +(bind-key "Delete Previous Character Expanding Tabs" #k"delete" :mode "Pascal") +(bind-key "Scribe Insert Bracket" #k")" :mode "Pascal") +(bind-key "Scribe Insert Bracket" #k"]" :mode "Pascal") +(bind-key "Scribe Insert Bracket" #k"}" :mode "Pascal") ;;;; Auto Fill Mode. -(bind-key "Fill Paragraph" #\meta-q) -(bind-key "Fill Region" #\meta-g) -(bind-key "Set Fill Prefix" '#(#\control-x #\.)) -(bind-key "Set Fill Column" '#(#\control-x #\f)) -(bind-key "Auto Fill Return" #\return :mode "Fill") -(bind-key "Auto Fill Space" #\space :mode "Fill") -(bind-key "Auto Fill Linefeed" #\linefeed :mode "Fill") +(bind-key "Fill Paragraph" #k"meta-q") +(bind-key "Fill Region" #k"meta-g") +(bind-key "Set Fill Prefix" #k"control-x .")) +(bind-key "Set Fill Column" #k"control-x f") +(bind-key "Auto Fill Return" #k"return" :mode "Fill") +(bind-key "Auto Fill Space" #k"space" :mode "Fill") +(bind-key "Auto Fill Linefeed" #k"linefeed" :mode "Fill") ;;;; Keyboard macro bindings. -(bind-key "Define Keyboard Macro" '#(#\control-x #\()) -(bind-key "Define Keyboard Macro Key" '#(#\control-x #\meta-\()) -(bind-key "End Keyboard Macro" '#(#\control-x #\))) -(bind-key "End Keyboard Macro" '#(#\control-x #\hyper-\))) -(bind-key "Last Keyboard Macro" '#(#\control-x #\e)) -(bind-key "Keyboard Macro Query" '#(#\control-x #\q)) +(bind-key "Define Keyboard Macro" #k"control-x (") +(bind-key "Define Keyboard Macro Key" #k"control-x meta-(") +(bind-key "End Keyboard Macro" #k"control-x )") +(bind-key "End Keyboard Macro" #k"control-x hyper-)") +(bind-key "Last Keyboard Macro" #k"control-x e") +(bind-key "Keyboard Macro Query" #k"control-x q") ;;;; Spell bindings. -(bind-key "Check Word Spelling" #\meta-$) -(bind-key "Add Word to Spelling Dictionary" '#(#\control-x #\$)) +(bind-key "Check Word Spelling" #k"meta-$") +(bind-key "Add Word to Spelling Dictionary" #k"control-x $") -(dolist (c (command-bindings (getstring "Self Insert" *command-names*))) - (let ((ch (svref (car c) 0))) - (unless (or (alpha-char-p ch) (char= ch #\')) - (bind-key "Auto Check Word Spelling" (car c) :mode "Spell")))) -(bind-key "Auto Check Word Spelling" #\return :mode "Spell") -(bind-key "Auto Check Word Spelling" #\tab :mode "Spell") -(bind-key "Auto Check Word Spelling" #\linefeed :mode "Spell") -(bind-key "Correct Last Misspelled Word" #\meta-\:) -(bind-key "Undo Last Spelling Correction" '#(#\control-x #\a)) +(dolist (info (command-bindings (getstring "Self Insert" *command-names*))) + (let* ((key-event (car info)) + (character (key-event-char (svref (car info) 0)))) + (unless (or (alpha-char-p character) (eq key-event #k"'")) + (bind-key "Auto Check Word Spelling" (car info) :mode "Spell")))) +(bind-key "Auto Check Word Spelling" #k"return" :mode "Spell") +(bind-key "Auto Check Word Spelling" #k"tab" :mode "Spell") +(bind-key "Auto Check Word Spelling" #k"linefeed" :mode "Spell") +(bind-key "Correct Last Misspelled Word" #k"meta-:") +(bind-key "Undo Last Spelling Correction" #k"control-x a") ;;;; Overwrite Mode. -(bind-key "Overwrite Delete Previous Character" #\delete :mode "Overwrite") -(bind-key "Overwrite Delete Previous Character" #\backspace :mode "Overwrite") +(bind-key "Overwrite Delete Previous Character" #k"delete" :mode "Overwrite") +(bind-key "Overwrite Delete Previous Character" #k"backspace" :mode "Overwrite") -;;; do up the printing characters ... -(do* ((i 33 (1+ i)) - (char (code-char i) (code-char i))) - ((= i 126)) - (bind-key "Self Overwrite" char :mode "Overwrite")) +;;; Do up the printing characters ... +(do ((i 33 (1+ i))) + ((= i 126)) + (let ((key-event (char-key-event (code-char i)))) + (bind-key "Self Overwrite" key-event :mode "Overwrite"))) -(bind-key "Self Overwrite" #\space :mode "Overwrite") +(bind-key "Self Overwrite" #k"space" :mode "Overwrite") ;;;; Comment bindings. -(bind-key "Indent for Comment" #\meta-\;) -(bind-key "Set Comment Column" '#(#\control-x #\;)) -(bind-key "Kill Comment" #\control-meta-\;) -(bind-key "Down Comment Line" #\meta-n) -(bind-key "Up Comment Line" #\meta-p) -(bind-key "Up Comment Line" #\meta-\p) -(bind-key "Indent New Comment Line" #\meta-j) -(bind-key "Indent New Comment Line" #\meta-linefeed) +(bind-key "Indent for Comment" #k"meta-;") +(bind-key "Set Comment Column" #k"control-x ;") +(bind-key "Kill Comment" #k"control-meta-;") +(bind-key "Down Comment Line" #k"meta-n") +(bind-key "Up Comment Line" #k"meta-p") +(bind-key "Indent New Comment Line" #k"meta-j") +(bind-key "Indent New Comment Line" #k"meta-linefeed") ;;;; Word Abbrev Mode. -(bind-key "Add Mode Word Abbrev" '#(#\Control-X #\Control-A)) -(bind-key "Add Global Word Abbrev" '#(#\Control-X #\+)) -(bind-key "Inverse Add Mode Word Abbrev" '#(#\Control-X #\Control-H)) -(bind-key "Inverse Add Global Word Abbrev" '#(#\Control-X #\-)) +(bind-key "Add Mode Word Abbrev" #k"control-x control-a") +(bind-key "Add Global Word Abbrev" #k"control-x +") +(bind-key "Inverse Add Mode Word Abbrev" #k"control-x control-h") +(bind-key "Inverse Add Global Word Abbrev" #k"control-x \-") ;; Removed in lieu of "Pop and Goto Mark". -;;(bind-key "Abbrev Expand Only" #\meta-space) -(bind-key "Word Abbrev Prefix Mark" #\meta-\") -(bind-key "Unexpand Last Word" '#(#\Control-X #\u)) -(bind-key "Unexpand Last Word" '#(#\Control-X #\U)) +;;(bind-key "Abbrev Expand Only" #k"meta-space") +(bind-key "Word Abbrev Prefix Mark" #k"meta-\"") +(bind-key "Unexpand Last Word" #k"control-x u") -(dolist (x '(#\! #\~ #\@ #\# #\; #\$ #\% #\^ #\& #\* #\- #\_ #\= #\+ #\[ #\] - #\( #\) #\/ #\| #\: #\' #\" #\{ #\} #\, #\< #\. #\> #\` #\\ #\? - #\return #\newline #\tab #\space)) - (bind-key "Abbrev Expand Only" x :mode "Abbrev")) +(dolist (key (list #k"!" #k"~" #k"@" #k"#" #k";" #k"$" #k"%" #k"^" #k"&" #k"*" + #k"\-" #k"_" #k"=" #k"+" #k"[" #k"]" #k"(" #k")" #k"/" #k"|" + #k":" #k"'" #k"\"" #k"{" #k"}" #k"," #k"\<" #k"." #k"\>" + #k"`" #k"\\" #k"?" #k"return" #k"newline" #k"tab" #k"space")) + (bind-key "Abbrev Expand Only" key :mode "Abbrev")) ;;;; Scribe Mode. -(dolist (ch '(#\] #\) #\} #\>)) - (bind-key "Scribe Insert Bracket" ch :mode "Scribe")) +(dolist (key (list #k"]" #k")" #k"}" #k"\>")) + (bind-key "Scribe Insert Bracket" key :mode "Scribe")) -(bind-key "Scribe Buffer File" '#(#\control-x #\c) :mode "Scribe") -(bind-key "Scribe Buffer File" '#(#\control-x #\C) :mode "Scribe") -(bind-key "Select Scribe Warnings" #\control-meta-C :mode "Scribe") +(bind-key "Scribe Buffer File" #k"control-x c" :mode "Scribe") +(bind-key "Select Scribe Warnings" #k"control-meta-C" :mode "Scribe") -(bind-key "Insert Scribe Directive" #\hyper-i :mode "Scribe") +(bind-key "Insert Scribe Directive" #k"hyper-i" :mode "Scribe") ;;;; X commands: -(bind-key "Insert Cut Buffer" #\insert) -(bind-key "Region to Cut Buffer" #\meta-insert) +(bind-key "Insert Cut Buffer" #k"insert") +(bind-key "Region to Cut Buffer" #k"meta-insert") ;;;; Mailer commands. -(do-alpha-chars (c :both) - (bind-key "Illegal" c :mode "Headers") - (bind-key "Illegal" c :mode "Message")) +(do-alpha-key-events (key-event :both) + (bind-key "Illegal" key-event :mode "Headers") + (bind-key "Illegal" key-event :mode "Message")) ;;; Global. -(bind-key "Incorporate and Read New Mail" '#(#\control-x #\i)) -(bind-key "Send Message" '#(#\control-x #\m)) -(bind-key "Message Headers" '#(#\control-x #\r)) -(bind-key "Message Headers" '#(#\control-x #\R)) +(bind-key "Incorporate and Read New Mail" #k"control-x i") +(bind-key "Send Message" #k"control-x m") +(bind-key "Message Headers" #k"control-x r") ;;; Both Headers and Message modes. @@ -630,180 +554,169 @@ ;;; and one for "Headers" mode. ;;; -(bind-key "Next Message" #\meta-n :mode "Message") -(bind-key "Previous Message" #\meta-p :mode "Message") -(bind-key "Previous Message" #\meta-\p :mode "Message") -(bind-key "Next Undeleted Message" #\n :mode "Message") -(bind-key "Previous Undeleted Message" #\p :mode "Message") -(bind-key "Send Message" #\s :mode "Message") -(bind-key "Send Message" #\m :mode "Message") -(bind-key "Forward Message" #\f :mode "Message") -(bind-key "Headers Delete Message" #\k :mode "Message") -(bind-key "Headers Undelete Message" #\u :mode "Message") -(bind-key "Headers Undelete Message" #\U :mode "Message") -(bind-key "Headers Refile Message" #\o :mode "Message") -(bind-key "List Mail Buffers" #\l :mode "Message") -(bind-key "Quit Headers" #\q :mode "Message") -(bind-key "Incorporate and Read New Mail" #\i :mode "Message") -(bind-key "Beginning of Buffer" #\< :mode "Message") -(bind-key "End of Buffer" #\> :mode "Message") - -(bind-key "Next Message" #\meta-n :mode "Headers") -(bind-key "Previous Message" #\meta-p :mode "Headers") -(bind-key "Previous Message" #\meta-\p :mode "Headers") -(bind-key "Next Undeleted Message" #\n :mode "Headers") -(bind-key "Previous Undeleted Message" #\p :mode "Headers") -(bind-key "Send Message" #\s :mode "Headers") -(bind-key "Send Message" #\m :mode "Headers") -(bind-key "Forward Message" #\f :mode "Headers") -(bind-key "Headers Delete Message" #\k :mode "Headers") -(bind-key "Headers Undelete Message" #\u :mode "Headers") -(bind-key "Headers Undelete Message" #\U :mode "Headers") -(bind-key "Headers Refile Message" #\o :mode "Headers") -(bind-key "List Mail Buffers" #\l :mode "Headers") -(bind-key "Quit Headers" #\q :mode "Headers") -(bind-key "Incorporate and Read New Mail" #\i :mode "Headers") -(bind-key "Beginning of Buffer" #\< :mode "Headers") -(bind-key "End of Buffer" #\> :mode "Headers") +(bind-key "Next Message" #k"meta-n" :mode "Message") +(bind-key "Previous Message" #k"meta-p" :mode "Message") +(bind-key "Next Undeleted Message" #k"n" :mode "Message") +(bind-key "Previous Undeleted Message" #k"p" :mode "Message") +(bind-key "Send Message" #k"s" :mode "Message") +(bind-key "Send Message" #k"m" :mode "Message") +(bind-key "Forward Message" #k"f" :mode "Message") +(bind-key "Headers Delete Message" #k"k" :mode "Message") +(bind-key "Headers Undelete Message" #k"u" :mode "Message") +(bind-key "Headers Refile Message" #k"o" :mode "Message") +(bind-key "List Mail Buffers" #k"l" :mode "Message") +(bind-key "Quit Headers" #k"q" :mode "Message") +(bind-key "Incorporate and Read New Mail" #k"i" :mode "Message") +(bind-key "Beginning of Buffer" #k"\<" :mode "Message") +(bind-key "End of Buffer" #k"\>" :mode "Message") + +(bind-key "Next Message" #k"meta-n" :mode "Headers") +(bind-key "Previous Message" #k"meta-p" :mode "Headers") +(bind-key "Next Undeleted Message" #k"n" :mode "Headers") +(bind-key "Previous Undeleted Message" #k"p" :mode "Headers") +(bind-key "Send Message" #k"s" :mode "Headers") +(bind-key "Send Message" #k"m" :mode "Headers") +(bind-key "Forward Message" #k"f" :mode "Headers") +(bind-key "Headers Delete Message" #k"k" :mode "Headers") +(bind-key "Headers Undelete Message" #k"u" :mode "Headers") +(bind-key "Headers Refile Message" #k"o" :mode "Headers") +(bind-key "List Mail Buffers" #k"l" :mode "Headers") +(bind-key "Quit Headers" #k"q" :mode "Headers") +(bind-key "Incorporate and Read New Mail" #k"i" :mode "Headers") +(bind-key "Beginning of Buffer" #k"\<" :mode "Headers") +(bind-key "End of Buffer" #k"\>" :mode "Headers") ;;; Headers mode. -(bind-key "Delete Message and Down Line" #\d :mode "Headers") -(bind-key "Delete Message and Down Line" #\D :mode "Headers") -(bind-key "Pick Headers" #\h :mode "Headers") -(bind-key "Show Message" #\space :mode "Headers") -(bind-key "Show Message" #\. :mode "Headers") -(bind-key "Reply to Message" #\r :mode "Headers") -(bind-key "Reply to Message" #\R :mode "Headers") -(bind-key "Expunge Messages" #\! :mode "Headers") -(bind-key "Headers Help" #\? :mode "Headers") +(bind-key "Delete Message and Down Line" #k"d" :mode "Headers") +(bind-key "Pick Headers" #k"h" :mode "Headers") +(bind-key "Show Message" #k"space" :mode "Headers") +(bind-key "Show Message" #k"." :mode "Headers") +(bind-key "Reply to Message" #k"r" :mode "Headers") +(bind-key "Expunge Messages" #k"!" :mode "Headers") +(bind-key "Headers Help" #k"?" :mode "Headers") ;;; Message mode. -(bind-key "Delete Message and Show Next" #\d :mode "Message") -(bind-key "Delete Message and Show Next" #\D :mode "Message") -(bind-key "Goto Headers Buffer" #\^ :mode "Message") -(bind-key "Scroll Message" #\space :mode "Message") -(bind-key "Scroll Message" #\control-v :mode "Message") -(bind-key "Scroll Window Up" #\backspace :mode "Message") -(bind-key "Scroll Window Up" #\delete :mode "Message") -(bind-key "Reply to Message in Other Window" #\r :mode "Message") -(bind-key "Reply to Message in Other Window" #\R :mode "Message") -(bind-key "Edit Message Buffer" #\e :mode "Message") -(bind-key "Insert Message Region" #\hyper-y :mode "Message") -(bind-key "Message Help" #\? :mode "Message") +(bind-key "Delete Message and Show Next" #k"d" :mode "Message") +(bind-key "Goto Headers Buffer" #k"^" :mode "Message") +(bind-key "Scroll Message" #k"space" :mode "Message") +(bind-key "Scroll Message" #k"control-v" :mode "Message") +(bind-key "Scroll Window Up" #k"backspace" :mode "Message") +(bind-key "Scroll Window Up" #k"delete" :mode "Message") +(bind-key "Reply to Message in Other Window" #k"r" :mode "Message") +(bind-key "Edit Message Buffer" #k"e" :mode "Message") +(bind-key "Insert Message Region" #k"hyper-y" :mode "Message") +(bind-key "Message Help" #k"?" :mode "Message") ;;; Draft mode. -(bind-key "Goto Headers Buffer" #\hyper-^ :mode "Draft") -(bind-key "Goto Message Buffer" #\hyper-m :mode "Draft") -(bind-key "Deliver Message" #\hyper-s :mode "Draft") -(bind-key "Deliver Message" #\hyper-c :mode "Draft") -(bind-key "Insert Message Buffer" #\hyper-y :mode "Draft") -(bind-key "Delete Draft and Buffer" #\hyper-q :mode "Draft") -(bind-key "List Mail Buffers" #\hyper-l :mode "Draft") -(bind-key "Draft Help" #\hyper-? :mode "Draft") +(bind-key "Goto Headers Buffer" #k"hyper-^" :mode "Draft") +(bind-key "Goto Message Buffer" #k"hyper-m" :mode "Draft") +(bind-key "Deliver Message" #k"hyper-s" :mode "Draft") +(bind-key "Deliver Message" #k"hyper-c" :mode "Draft") +(bind-key "Insert Message Buffer" #k"hyper-y" :mode "Draft") +(bind-key "Delete Draft and Buffer" #k"hyper-q" :mode "Draft") +(bind-key "List Mail Buffers" #k"hyper-l" :mode "Draft") +(bind-key "Draft Help" #k"hyper-?" :mode "Draft") ;;;; Process (Shell). -(bind-key "Confirm Process Input" #\return :mode "Process") -(bind-key "Shell" #\control-meta-\s) -(bind-key "Interrupt Buffer Subprocess" #\hyper-c :mode "Process") -(bind-key "Stop Buffer Subprocess" #\hyper-z :mode "Process") -(bind-key "Quit Buffer Subprocess" #\hyper-\\) -(bind-key "Send EOF to Process" #\hyper-d) +(bind-key "Confirm Process Input" #k"return" :mode "Process") +(bind-key "Shell" #k"control-meta-s") +(bind-key "Interrupt Buffer Subprocess" #k"hyper-c" :mode "Process") +(bind-key "Stop Buffer Subprocess" #k"hyper-z" :mode "Process") +(bind-key "Quit Buffer Subprocess" #k"hyper-\\") +(bind-key "Send EOF to Process" #k"hyper-d") -(bind-key "Previous Interactive Input" #\meta-\p :mode "Process") -(bind-key "Search Previous Interactive Input" #\meta-P :mode "Process") -(bind-key "Interactive Beginning of Line" #\control-a :mode "Process") -(bind-key "Kill Interactive Input" #\meta-i :mode "Process") -(bind-key "Next Interactive Input" #\meta-n :mode "Process") -(bind-key "Reenter Interactive Input" #\control-return :mode "Process") +(bind-key "Previous Interactive Input" #k"meta-p" :mode "Process") +(bind-key "Search Previous Interactive Input" #k"meta-P" :mode "Process") +(bind-key "Interactive Beginning of Line" #k"control-a" :mode "Process") +(bind-key "Kill Interactive Input" #k"meta-i" :mode "Process") +(bind-key "Next Interactive Input" #k"meta-n" :mode "Process") +(bind-key "Reenter Interactive Input" #k"control-return" :mode "Process") ;;;; Bufed. -(bind-key "Bufed" '#(#\control-x #\control-meta-b)) -(bind-key "Bufed Delete" #\d :mode "Bufed") -(bind-key "Bufed Delete" #\D :mode "Bufed") -(bind-key "Bufed Delete" #\control-d :mode "Bufed") -(bind-key "Bufed Delete" #\control-\d :mode "Bufed") -(bind-key "Bufed Undelete" #\u :mode "Bufed") -(bind-key "Bufed Undelete" #\U :mode "Bufed") -(bind-key "Bufed Expunge" #\! :mode "Bufed") -(bind-key "Bufed Quit" #\q :mode "Bufed") -(bind-key "Bufed Goto" #\space :mode "Bufed") -(bind-key "Bufed Goto and Quit" #\super-leftdown :mode "Bufed") -(bind-key "Bufed Save File" #\s :mode "Bufed") -(bind-key "Next Line" #\n :mode "Bufed") -(bind-key "Previous Line" #\p :mode "Bufed") +(bind-key "Bufed" #k"control-x control-meta-b")) +(bind-key "Bufed Delete" #k"d" :mode "Bufed") +(bind-key "Bufed Delete" #k"control-d" :mode "Bufed") +(bind-key "Bufed Undelete" #k"u" :mode "Bufed") +(bind-key "Bufed Expunge" #k"!" :mode "Bufed") +(bind-key "Bufed Quit" #k"q" :mode "Bufed") +(bind-key "Bufed Goto" #k"space" :mode "Bufed") +(bind-key "Bufed Goto and Quit" #k"super-leftdown" :mode "Bufed") +(bind-key "Bufed Save File" #k"s" :mode "Bufed") +(bind-key "Next Line" #k"n" :mode "Bufed") +(bind-key "Previous Line" #k"p" :mode "Bufed") -(bind-key "Bufed Help" #\? :mode "Bufed") +(bind-key "Bufed Help" #k"?" :mode "Bufed") ;;;; Dired. -(bind-key "Dired" '#(#\control-x #\control-meta-\d)) +(bind-key "Dired" #k"control-x control-meta-d")) -(bind-key "Dired Delete File and Down Line" #\d :Mode "Dired") -(bind-key "Dired Delete File with Pattern" #\D :Mode "Dired") -(bind-key "Dired Delete File" #\control-\d :Mode "Dired") -(bind-key "Dired Delete File" #\control-d :Mode "Dired") -(bind-key "Dired Delete File" #\k :Mode "Dired") +(bind-key "Dired Delete File and Down Line" #k"d" :mode "Dired") +(bind-key "Dired Delete File with Pattern" #k"D" :mode "Dired") +(bind-key "Dired Delete File" #k"control-d" :mode "Dired") +(bind-key "Dired Delete File" #k"k" :mode "Dired") -(bind-key "Dired Undelete File and Down Line" #\u :Mode "Dired") -(bind-key "Dired Undelete File with Pattern" #\U :Mode "Dired") -(bind-key "Dired Undelete File" #\control-u :Mode "Dired") +(bind-key "Dired Undelete File and Down Line" #k"u" :mode "Dired") +(bind-key "Dired Undelete File with Pattern" #k"U" :mode "Dired") +(bind-key "Dired Undelete File" #k"control-u" :mode "Dired") -(bind-key "Dired Expunge Files" #\! :Mode "Dired") -(bind-key "Dired Update Buffer" #\hyper-u :Mode "Dired") -(bind-key "Dired View File" #\space :Mode "Dired") -(bind-key "Dired Edit File" #\e :Mode "Dired") -(bind-key "Dired Quit" #\q :Mode "Dired") -(bind-key "Dired Help" #\? :Mode "Dired") +(bind-key "Dired Expunge Files" #k"!" :mode "Dired") +(bind-key "Dired Update Buffer" #k"hyper-u" :mode "Dired") +(bind-key "Dired View File" #k"space" :mode "Dired") +(bind-key "Dired Edit File" #k"e" :mode "Dired") +(bind-key "Dired Up Directory" #k"^" :mode "Dired") +(bind-key "Dired Quit" #k"q" :mode "Dired") +(bind-key "Dired Help" #k"?" :mode "Dired") -(bind-key "Dired Copy File" #\c :Mode "Dired") -(bind-key "Dired Copy with Wildcard" #\C :Mode "Dired") -(bind-key "Dired Rename File" #\r :Mode "Dired") -(bind-key "Dired Rename with Wildcard" #\R :Mode "Dired") +(bind-key "Dired Copy File" #k"c" :mode "Dired") +(bind-key "Dired Copy with Wildcard" #k"C" :mode "Dired") +(bind-key "Dired Rename File" #k"r" :mode "Dired") +(bind-key "Dired Rename with Wildcard" #k"R" :mode "Dired") -(bind-key "Next Line" #\n :mode "Dired") -(bind-key "Previous Line" #\p :mode "Dired") +(bind-key "Next Line" #k"n" :mode "Dired") +(bind-key "Previous Line" #k"p" :mode "Dired") ;;;; View Mode. -(bind-key "View Scroll Down" #\space :mode "View") -(bind-key "Scroll Window Up" #\b :mode "View") -(bind-key "Scroll Window Up" #\backspace :Mode "View") -(bind-key "Scroll Window Up" #\delete :Mode "View") -(bind-key "View Return" #\^ :mode "View") -(bind-key "View Quit" #\q :mode "View") -(bind-key "View Edit File" #\e :mode "View") -(bind-key "View Help" #\? :mode "View") -(bind-key "Beginning of Buffer" #\< :Mode "View") -(bind-key "End of Buffer" #\> :Mode "View") +(bind-key "View Scroll Down" #k"space" :mode "View") +(bind-key "Scroll Window Up" #k"b" :mode "View") +(bind-key "Scroll Window Up" #k"backspace" :mode "View") +(bind-key "Scroll Window Up" #k"delete" :mode "View") +(bind-key "View Return" #k"^" :mode "View") +(bind-key "View Quit" #k"q" :mode "View") +(bind-key "View Edit File" #k"e" :mode "View") +(bind-key "View Help" #k"?" :mode "View") +(bind-key "Beginning of Buffer" #k"\<" :mode "View") +(bind-key "End of Buffer" #k"\>" :mode "View") ;;;; Lisp Library. -(bind-key "Describe Pointer Library Entry" #\leftdown :Mode "Lisp-Lib") -(bind-key "Load Pointer Library Entry" #\rightdown :Mode "Lisp-Lib") -(bind-key "Describe Library Entry" #\space :Mode "Lisp-Lib") -(bind-key "Load Library Entry" #\l :Mode "Lisp-Lib") -(bind-key "Exit Lisp Library" #\q :Mode "Lisp-Lib") -(bind-key "Lisp Library Help" #\? :Mode "Lisp-Lib") +(bind-key "Describe Pointer Library Entry" #k"leftdown" :mode "Lisp-Lib") +(bind-key "Load Pointer Library Entry" #k"rightdown" :mode "Lisp-Lib") +(bind-key "Describe Library Entry" #k"space" :mode "Lisp-Lib") +(bind-key "Load Library Entry" #k"l" :mode "Lisp-Lib") +(bind-key "Exit Lisp Library" #k"q" :mode "Lisp-Lib") +(bind-key "Lisp Library Help" #k"?" :mode "Lisp-Lib") @@ -812,38 +725,43 @@ (dolist (c (command-bindings (getstring "Self Insert" *command-names*))) (bind-key "Completion Self Insert" (car c) :mode "Completion")) -(bind-key "Completion Self Insert" #\Space :mode "Completion") -(bind-key "Completion Self Insert" #\Tab :mode "Completion") -(bind-key "Completion Self Insert" #\Return :mode "Completion") -(bind-key "Completion Self Insert" #\Linefeed :mode "Completion") +(bind-key "Completion Self Insert" #k"space" :mode "Completion") +(bind-key "Completion Self Insert" #k"tab" :mode "Completion") +(bind-key "Completion Self Insert" #k"return" :mode "Completion") +(bind-key "Completion Self Insert" #k"linefeed" :mode "Completion") -(bind-key "Completion Complete Word" #\End) -(bind-key "Completion Rotate Completions" #\Meta-End) +(bind-key "Completion Complete Word" #k"end") +(bind-key "Completion Rotate Completions" #k"meta-end") -;;;; Logical characters. +;;;; Caps-Lock mode. + +(do-alpha-key-events (key-event :lower) + (bind-key "Self Insert Caps Lock" key-event :mode "CAPS-LOCK")) -(setf (logical-char= #\control-s :forward-search) t) -(setf (logical-char= #\control-r :backward-search) t) -(setf (logical-char= #\control-r :recursive-edit) t) -(setf (logical-char= #\delete :cancel) t) -(setf (logical-char= #\backspace :cancel) t) -(setf (logical-char= #\control-g :abort) t) -(setf (logical-char= #\escape :exit) t) -(setf (logical-char= #\Y :yes) t) -(setf (logical-char= #\space :yes) t) -(setf (logical-char= #\N :no) t) -(setf (logical-char= #\backspace :no) t) -(setf (logical-char= #\delete :no) t) -(setf (logical-char= #\! :do-all) t) -(setf (logical-char= #\. :do-once) t) -(setf (logical-char= #\home :help) t) -(setf (logical-char= #\H :help) t) -(setf (logical-char= #\? :help) t) -(setf (logical-char= #\control-_ :help) t) -(setf (logical-char= #\return :confirm) t) -(setf (logical-char= #\control-q :quote) t) -(setf (logical-char= #\K :keep) t) + +;;;; Logical characters. +(setf (logical-key-event-p #k"control-s" :forward-search) t) +(setf (logical-key-event-p #k"control-r" :backward-search) t) +(setf (logical-key-event-p #k"control-r" :recursive-edit) t) +(setf (logical-key-event-p #k"delete" :cancel) t) +(setf (logical-key-event-p #k"backspace" :cancel) t) +(setf (logical-key-event-p #k"control-g" :abort) t) +(setf (logical-key-event-p #k"escape" :exit) t) +(setf (logical-key-event-p #k"y" :yes) t) +(setf (logical-key-event-p #k"space" :yes) t) +(setf (logical-key-event-p #k"n" :no) t) +(setf (logical-key-event-p #k"backspace" :no) t) +(setf (logical-key-event-p #k"delete" :no) t) +(setf (logical-key-event-p #k"!" :do-all) t) +(setf (logical-key-event-p #k"." :do-once) t) +(setf (logical-key-event-p #k"home" :help) t) +(setf (logical-key-event-p #k"h" :help) t) +(setf (logical-key-event-p #k"?" :help) t) +(setf (logical-key-event-p #k"control-_" :help) t) +(setf (logical-key-event-p #k"return" :confirm) t) +(setf (logical-key-event-p #k"control-q" :quote) t) +(setf (logical-key-event-p #k"k" :keep) t) diff --git a/hemlock/bit-screen.lisp b/hemlock/bit-screen.lisp index 715a39c60..c6fa137d4 100644 --- a/hemlock/bit-screen.lisp +++ b/hemlock/bit-screen.lisp @@ -509,7 +509,7 @@ (declare (ignore event-key event-window root child same-screen-p root-x root-y time send-event-p)) (hunk-process-input hunk - (ext:translate-character + (ext:translate-key-event (bitmap-device-display (device-hunk-device hunk)) key-code modifiers) x y)) @@ -521,7 +521,7 @@ (declare (ignore event-window root child same-screen-p root-x root-y time send-event-p)) (hunk-process-input hunk - (ext:translate-mouse-character key-code modifiers + (ext:translate-mouse-key-event key-code modifiers event-key) x y)) ;;; diff --git a/hemlock/buffer.lisp b/hemlock/buffer.lisp index bb36a49b7..bf6aa1750 100644 --- a/hemlock/buffer.lisp +++ b/hemlock/buffer.lisp @@ -487,7 +487,7 @@ name " Mode.")) (setq mode (make-mode-object :variables (make-string-table) - :bindings (make-key-table) + :bindings (make-hash-table) :hook-name (getstring hook-str *global-variable-names*))) (setf (getstring name *mode-names*) mode))) @@ -547,7 +547,7 @@ :%region region :modes (list (mode-object-name object)) :mode-objects (list object) - :bindings (make-key-table) + :bindings (make-hash-table) :point (copy-mark (region-end region)) :display-start (copy-mark (region-start region)) :delete-hook delete-hook diff --git a/hemlock/charmacs.lisp b/hemlock/charmacs.lisp index aaf6bde2f..8f21fc171 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.") @@ -47,7 +42,7 @@ "Mask we AND with characters given to syntax table functions to blow away bits we don't want.") (defmacro syntax-char-code (char) - `(logand syntax-char-code-mask (char-code ,char))) + `(logand syntax-char-code-mask (lisp::%sp-make-fixnum ,char))) ;;;; Stuff for the command interpreter (interp) ;;; @@ -61,9 +56,10 @@ (defconstant command-char-bits-limit 16 "The maximum value of character bits supported for key bindings.") (defmacro key-char-bits (char) - `(logand (char-bits ,char) #xF)) + `(ash (logand #x+F00 (lisp::%sp-make-fixnum ,char)) -8)) (defmacro key-char-code (char) `(char-code ,char)) +;;; `(logand #x+7f (lisp::%sp-make-fixnum ,char))) can't use with X scan-codes. ;;;; Stuff used by the searching primitives (search) @@ -71,7 +67,7 @@ (defconstant search-char-code-limit 128 "The exclusive upper bound on significant char-codes for searching.") (defmacro search-char-code (ch) - `(logand (char-code ,ch) #x+7F)) + `(logand (lisp::%sp-make-fixnum ,ch) #x+7F)) ;;; ;;; search-hash-code must be a function with the following properties: ;;; given any character it returns a number between 0 and @@ -80,97 +76,16 @@ ;;; In ASCII this is can be done by ANDing out the 5'th bit. ;;; (defmacro search-hash-code (ch) - `(logand (char-code ,ch) #x+5F)) + `(logand (lisp::%sp-make-fixnum ,ch) #x+5F)) ;;; Doesn't do anything special, but it should fast and not waste any time ;;; checking type and whatnot. (defmacro search-char-upcase (ch) - `(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) + `(lisp::fast-char-upcase ,ch)) - ("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/command.lisp b/hemlock/command.lisp index 2e3675494..d7a34dd2c 100644 --- a/hemlock/command.lisp +++ b/hemlock/command.lisp @@ -49,7 +49,7 @@ "Insert the last character typed. With prefix argument insert the character that many times." "Implements ``Self Insert'', calling this function is not meaningful." - (let ((char (text-character *last-character-typed*))) + (let ((char (ext:key-event-char *last-key-event-typed*))) (unless char (editor-error "Can't insert that character.")) (if (and p (> p 1)) (insert-string @@ -60,8 +60,8 @@ (defcommand "Quoted Insert" (p) "Read a character from the terminal and insert it. With prefix argument, insert the character that many times." - "Reads a character from *editor-input* and inserts it at the point." - (let ((char (text-character (read-char *editor-input* nil))) + "Reads a key-event from *editor-input* and inserts it at the point." + (let ((char (ext:key-event-char (get-key-event *editor-input* t))) (point (current-point))) (unless char (editor-error "Can't insert that character.")) (if (and p (> p 1)) @@ -399,16 +399,17 @@ (declare (ignore p)) (clear-echo-area) (write-string "C-U " *echo-area-stream*) - (let ((char (read-char *editor-input*))) + (let* ((key-event (get-key-event *editor-input*)) + (char (ext:key-event-char key-event))) (multiple-value-call #'universal-argument-loop (case (char-code char) (#.(char-code #\-) (write-char #\- *echo-area-stream*) - (values (read-char *editor-input*) -1)) + (values (get-key-event *editor-input*) -1)) (#.(char-code #\+) ;Just in case. (write-char #\+ *echo-area-stream*) - (values (read-char *editor-input*) 1)) - (t (values char 1)))))) + (values (get-key-event *editor-input*) 1)) + (t (values key-event 1)))))) (defcommand "Negative Argument" (p) "This command is equivalent to invoking \"Universal Argument\" and typing @@ -418,7 +419,7 @@ (when p (editor-error "Must type minus sign first.")) (clear-echo-area) (write-string "C-U -" *echo-area-stream*) - (universal-argument-loop (read-char *editor-input*) -1)) + (universal-argument-loop (get-key-event *editor-input*) -1)) (defcommand "Argument Digit" (p) "This command is equivalent to invoking \"Universal Argument\" and typing @@ -428,9 +429,9 @@ (declare (ignore p)) (clear-echo-area) (write-string "C-U " *echo-area-stream*) - (universal-argument-loop *last-character-typed* 1)) + (universal-argument-loop *last-key-event-typed* 1)) -(defun universal-argument-loop (char sign &optional (multiplier 1)) +(defun universal-argument-loop (key-event sign &optional (multiplier 1)) (flet ((prefix (sign multiplier read-some-digit-p result) ;; read-some-digit-p and (zerop result) are not ;; equivalent if the user invokes this and types 0. @@ -438,26 +439,29 @@ (if read-some-digit-p result (value universal-argument-default))))) - (let* ((display-char (make-char char)) - (digit (digit-char-p display-char)) + (let* ((stripped-key-event (if key-event (ext:make-key-event key-event))) + (char (ext:key-event-char stripped-key-event)) + (digit (if char (digit-char-p char))) (result 0) (read-some-digit-p nil)) (loop (cond (digit (setf read-some-digit-p t) - (write-char display-char *echo-area-stream*) - (setq result (+ digit (* 10 result))) - (setf char (read-char *editor-input*)) - (setf display-char (make-char char)) - (setf digit (digit-char-p display-char))) - ((or (char= char #\c-u) (char= char #\c-\u)) + (write-char char *echo-area-stream*) + (setf result (+ digit (* 10 result))) + (setf key-event (get-key-event *editor-input*)) + (setf stripped-key-event (if key-event + (ext:make-key-event key-event))) + (setf char (ext:key-event-char stripped-key-event)) + (setf digit (if char (digit-char-p char)))) + ((or (eq key-event #k"C-u") (eq key-event #k"C-U")) (write-string " C-U " *echo-area-stream*) (universal-argument-loop - (read-char *editor-input*) 1 + (get-key-event *editor-input*) 1 (prefix sign multiplier read-some-digit-p result)) (return)) (t - (unread-char char *editor-input*) + (unget-key-event key-event *editor-input*) (setf (prefix-argument) (prefix sign multiplier read-some-digit-p result)) (return)))))) diff --git a/hemlock/completion.lisp b/hemlock/completion.lisp index d47a7e6d5..5d706d2de 100644 --- a/hemlock/completion.lisp +++ b/hemlock/completion.lisp @@ -219,7 +219,7 @@ argument insert the character that many times." "Implements \"Completion Self Insert\". Calling this function is not meaningful." - (let ((char (text-character *last-character-typed*))) + (let ((char (ext:key-event-char *last-key-event-typed*))) (unless char (editor-error "Can't insert that character.")) (cond ((completion-char-p char) ;; If start of word not already in *completion-prefix*, put it @@ -328,13 +328,20 @@ (let* ((first (position-if #'alpha-char-p string)) (next (if first (position-if #'alpha-char-p string :start (1+ first))))) + ;; Often completions start with asterisks when hacking on Lisp + ;; code, so we look for alphabetic characters. (insert-string point - (cond ((and first (lower-case-p (char string first))) - completion) - ((and next (lower-case-p (char string next))) - (word-capitalize completion)) - (t - (string-upcase completion)))))))))) + ;; Leave the cascading IF's alone. + ;; Writing this as a COND, using LOWER-CASE-P as + ;; the test is not equivalent to this code since + ;; numbers (and such) are nil for LOWER-CASE-P and + ;; UPPER-CASE-P. + (if (and first (upper-case-p (schar string first))) + (if (and next + (upper-case-p (schar string next))) + (string-upcase completion) + (word-capitalize completion)) + completion)))))))) ;;; WORD-CAPITALIZE is like STRING-CAPITALIZE except that it treats apostrophes diff --git a/hemlock/diredcoms.lisp b/hemlock/diredcoms.lisp index a7ff58aec..6c427ed6b 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. @@ -417,12 +434,14 @@ (defcommand "Dired Next File" (p) "Moves to next undeleted file." "Moves to next undeleted file." + (declare (ignore p)) (unless (dired-line-offset (current-point) (or p 1)) (editor-error "Not enough lines."))) (defcommand "Dired Previous File" (p) "Moves to previous undeleted file." "Moves to next undeleted file." + (declare (ignore p)) (unless (dired-line-offset (current-point) (or p -1)) (editor-error "Not enough lines."))) diff --git a/hemlock/doccoms.lisp b/hemlock/doccoms.lisp index 1a937c2d4..a7288b037 100644 --- a/hemlock/doccoms.lisp +++ b/hemlock/doccoms.lisp @@ -27,27 +27,27 @@ (declare (ignore p)) (command-case (:prompt "Doc (Help for Help): " :help "Type a Help option to say what kind of help you want:") - (#\A "List all commands, variables and attributes Apropos a keyword." + (#\a "List all commands, variables and attributes Apropos a keyword." (apropos-command nil)) - (#\D "Describe a command, given its name." + (#\d "Describe a command, given its name." (describe-command-command nil)) - (#\G "Generic describe, any Hemlock thing (e.g., variables, keys, attributes)." + (#\g "Generic describe, any Hemlock thing (e.g., variables, keys, attributes)." (generic-describe-command nil)) - (#\V "Describe variable and show its values." + (#\v "Describe variable and show its values." (describe-and-show-variable-command nil)) - (#\C "Describe the command bound to a Character." + (#\c "Describe the command bound to a Character." (describe-key-command nil)) - (#\L "List the last 60 characters typed." + (#\l "List the last 60 characters typed." (what-lossage-command nil)) - (#\M "Describe a mode." + (#\m "Describe a mode." (describe-mode-command nil)) - (#\P "Describe commands with mouse/pointer bindings." + (#\p "Describe commands with mouse/pointer bindings." (describe-pointer-command nil)) - (#\W "Find out Where a command is bound." + (#\w "Find out Where a command is bound." (where-is-command nil)) - (#\T "Describe a Lisp object." + (#\t "Describe a Lisp object." (editor-describe-command nil)) - ((#\Q :no) "Quits, You don't really want help."))) + ((#\q :no) "Quits, You don't really want help."))) (defcommand "Where Is" (p) "Find what key a command is bound to. @@ -172,8 +172,10 @@ "Prompt for a sequence of characters. When the first character is typed that terminates a key binding in the current context, describe the command bound to it. When the first character is typed that no longer allows a correct - key to be entered, tell the user that this sequence is not bound to anything." - "Print out the command documentation for a key which is prompted for." + key to be entered, tell the user that this sequence is not bound to + anything." + "Print out the command documentation for a key + which is prompted for." (declare (ignore p)) (let ((old-window (current-window))) (unwind-protect @@ -182,20 +184,21 @@ (hi::display-prompt-nicely "Describe key: " nil) (setf (fill-pointer hi::*prompt-key*) 0) (loop - (let ((char (read-char hi::*editor-input*))) - (vector-push-extend char hi::*prompt-key*) + (let ((key-event (get-key-event hi::*editor-input*))) + (vector-push-extend key-event hi::*prompt-key*) (let ((res (get-command hi::*prompt-key* :current))) - (format hi::*echo-area-stream* "~:C " char) + (ext:print-pretty-key-event key-event *echo-area-stream*) + (write-char #\space *echo-area-stream*) (cond ((commandp res) (with-pop-up-display (s) - (sub-print-key (copy-seq hi::*prompt-key*) s) + (print-pretty-key (copy-seq hi::*prompt-key*) s) (format s " is bound to ~S.~%" (command-name res)) (format s "Documentation for this command:~% ~A" (command-documentation res))) (return)) ((not (eq res :prefix)) (with-pop-up-display (s :height 1) - (sub-print-key (copy-seq hi::*prompt-key*) s) + (print-pretty-key (copy-seq hi::*prompt-key*) s) (write-string " is not bound to anything." s)) (return))))))) (setf (current-window) old-window)))) @@ -227,9 +230,9 @@ (let ((key (car b))) (declare (simple-vector key)) (when (dotimes (i (length key) nil) - (when (member (make-char (svref key i)) - '(#\leftdown #\leftup #\middledown #\middleup - #\rightdown #\rightup)) + (when (member (ext:make-key-event (svref key i)) + (list #k"Leftdown" #k"Leftup" #k"Middledown" + #k"Middleup" #k"Rightdown" #k"Rightup")) (push cmd result) (return t))) (return))))))) @@ -365,7 +368,7 @@ (defun key-to-string (key) (with-output-to-string (s) - (sub-print-key key s))) + (print-pretty-key key s))) @@ -376,11 +379,11 @@ "Display the last 60 characters typed." (declare (ignore p)) (with-pop-up-display (s :height 7) - (let ((num (ring-length *character-history*))) + (let ((num (ring-length *key-event-history*))) (format s "The last ~D characters typed:~%" num) (do ((i (1- num) (1- i))) ((minusp i)) - (print-pretty-character (ring-ref *character-history* i) s) + (ext:print-pretty-key-event (ring-ref *key-event-history* i) s) (write-char #\space s))))) (defun print-command-bindings (bindings stream) @@ -418,17 +421,6 @@ (defun print-some-keys (keys stream) (do ((key keys (cdr key))) ((null (cdr key)) - (sub-print-key (car key) stream)) - (sub-print-key (car key) stream) + (print-pretty-key (car key) stream)) + (print-pretty-key (car key) stream) (write-string ", " stream))) - -;;; SUB-PRINT-KEY writes key on stream as a serious pretty printed characters -;;; separated by spaces. -;;; -(defun sub-print-key (key stream) - (declare (simple-vector key)) - (let ((last (1- (length key)))) - (dotimes (i last) - (print-pretty-character (svref key i) stream) - (write-char #\space stream)) - (print-pretty-character (svref key last) stream))) diff --git a/hemlock/echo.lisp b/hemlock/echo.lisp index bea9cacad..47c1e62c6 100644 --- a/hemlock/echo.lisp +++ b/hemlock/echo.lisp @@ -12,7 +12,7 @@ ;;; Written by Skef Wholey and Rob MacLachlan. ;;; Modified by Bill Chiles. ;;; -(in-package 'hemlock-internals) +(in-package "HEMLOCK-INTERNALS") (export '(*echo-area-buffer* *echo-area-stream* *echo-area-window* *parse-starting-mark* *parse-input-region* *parse-verification-function* *parse-string-tables* @@ -21,10 +21,10 @@ prompt-for-buffer prompt-for-file prompt-for-integer prompt-for-keyword prompt-for-expression prompt-for-string prompt-for-variable prompt-for-yes-or-no prompt-for-y-or-n - prompt-for-character prompt-for-key *logical-character-names* - logical-char= logical-character-documentation - logical-character-name logical-character-characters - define-logical-character *parse-type* current-variable-tables)) + prompt-for-key-event prompt-for-key *logical-key-event-names* + logical-key-event-p logical-key-event-documentation + logical-key-event-name logical-key-event-key-events + define-logical-key-event *parse-type* current-variable-tables)) (defmode "Echo Area" :major-p t) @@ -463,43 +463,45 @@ "Prompts for Y or N." (let ((old-window (current-window))) (unwind-protect - (progn - (setf (current-window) *echo-area-window*) - (display-prompt-nicely prompt (or default-string - (if defaultp (if default "Y" "N")))) - (do ((char (read-char *editor-input*) (read-char *editor-input*))) - (()) - (cond ((or (char= char #\y) (char= char #\Y)) - (return t)) - ((or (char= char #\n) (char= char #\N)) - (return nil)) - ((logical-char= char :confirm) - (if defaultp - (return default) - (beep))) - ((logical-char= char :help) - (ed::help-on-parse-command ())) - (t - (unless must-exist (return char)) - (beep))))) + (progn + (setf (current-window) *echo-area-window*) + (display-prompt-nicely prompt (or default-string + (if defaultp (if default "Y" "N")))) + (loop + (let ((key-event (get-key-event *editor-input*))) + (cond ((or (eq key-event #k"y") + (eq key-event #k"Y")) + (return t)) + ((or (eq key-event #k"n") + (eq key-event #k"N")) + (return nil)) + ((logical-key-event-p key-event :confirm) + (if defaultp + (return default) + (beep))) + ((logical-key-event-p key-event :help) + (ed::help-on-parse-command ())) + (t + (unless must-exist (return key-event)) + (beep)))))) (setf (current-window) old-window)))) -;;;; Character and key prompting. +;;;; Key-event and key prompting. -(defun prompt-for-character (&key (prompt "Character: ") (change-window t)) - "Prompts for a character." - (prompt-for-character* prompt change-window)) +(defun prompt-for-key-event (&key (prompt "Key-event: ") (change-window t)) + "Prompts for a key-event." + (prompt-for-key-event* prompt change-window)) -(defun prompt-for-character* (prompt change-window) +(defun prompt-for-key-event* (prompt change-window) (let ((old-window (current-window))) (unwind-protect - (progn - (when change-window - (setf (current-window) *echo-area-window*)) - (display-prompt-nicely prompt) - (read-char *editor-input* nil)) + (progn + (when change-window + (setf (current-window) *echo-area-window*)) + (display-prompt-nicely prompt) + (get-key-event *editor-input* t)) (when change-window (setf (current-window) old-window))))) (defvar *prompt-key* (make-array 10 :adjustable t :fill-pointer 0)) @@ -514,175 +516,177 @@ (format nil "~:C~{ ~:C~}" (car l) (cdr l))))))) (unwind-protect - (progn - (setf (current-window) *echo-area-window*) - (display-prompt-nicely prompt string) - (setf (fill-pointer *prompt-key*) 0) - (prog ((key *prompt-key*) char) - (declare (vector key)) - TOP - (setq char (read-char *editor-input*)) - (cond ((logical-char= char :quote) - (setq char (read-char *editor-input* nil))) - ((logical-char= char :confirm) - (cond ((and default (zerop (length key))) - (let ((res (get-command default :current))) - (unless (commandp res) (go FLAME)) - (return (values default res)))) - ((and (not must-exist) (plusp (length key))) - (return (copy-seq key))) - (t - (go FLAME)))) - ((logical-char= char :help) - (ed::help-on-parse-command ()) + (progn + (setf (current-window) *echo-area-window*) + (display-prompt-nicely prompt string) + (setf (fill-pointer *prompt-key*) 0) + (prog ((key *prompt-key*) key-event) + (declare (vector key)) + TOP + (setf key-event (get-key-event *editor-input*)) + (cond ((logical-key-event-p key-event :quote) + (setf key-event (get-key-event *editor-input* t))) + ((logical-key-event-p key-event :confirm) + (cond ((and default (zerop (length key))) + (let ((res (get-command default :current))) + (unless (commandp res) (go FLAME)) + (return (values default res)))) + ((and (not must-exist) (plusp (length key))) + (return (copy-seq key))) + (t + (go FLAME)))) + ((logical-key-event-p key-event :help) + (ed::help-on-parse-command ()) + (go TOP))) + (vector-push-extend key-event key) + (when must-exist + (let ((res (get-command key :current))) + (cond ((commandp res) + (ext:print-pretty-key-event key-event + *echo-area-stream* + t) + (write-char #\space *echo-area-stream*) + (return (values (copy-seq key) res))) + ((not (eq res :prefix)) + (vector-pop key) + (go FLAME))))) + (print-pretty-key key-event *echo-area-stream* t) + (write-char #\space *echo-area-stream*) + (go TOP) + FLAME + (beep) (go TOP))) - (vector-push-extend char key) - (when must-exist - (let ((res (get-command key :current))) - (cond ((commandp res) - (format *echo-area-stream* "~:C " char) - (return (values (copy-seq key) res))) - ((not (eq res :prefix)) - (vector-pop key) - (go FLAME))))) - (format *echo-area-stream* "~:C " char) - (go TOP) - FLAME - (beep) - (go TOP))) (force-output *echo-area-stream*) (setf (current-window) old-window)))) -;;;; Logical character stuff. +;;;; Logical key-event stuff. -(defvar *logical-character-names* (make-string-table) - "This variable holds a string-table from logical-character names to the - corresponding keywords.") +(defvar *logical-key-event-names* (make-string-table) + "This variable holds a string-table from logical-key-event names to the + corresponding keywords.") -(defvar *real-to-logical-characters* (make-hash-table :test #'eql) - "A hashtable from real characters to their corresponding logical - character keywords.") +(defvar *real-to-logical-key-events* (make-hash-table :test #'eql) + "A hashtable from real key-events to their corresponding logical + key-event keywords.") -(defvar *logical-character-descriptors* (make-hash-table :test #'eq) - "A hashtable from logical-characters to logical-character-descriptors.") +(defvar *logical-key-event-descriptors* (make-hash-table :test #'eq) + "A hashtable from logical-key-events to logical-key-event-descriptors.") -(defstruct (logical-character-descriptor - (:constructor make-logical-character-descriptor ())) +(defstruct (logical-key-event-descriptor + (:constructor make-logical-key-event-descriptor ())) name - characters + key-events documentation) -;;; Logical-Char= -- Public +;;; LOGICAL-KEY-EVENT-P -- Public ;;; -;;; Just look up the character in the hashtable. +(defun logical-key-event-p (key-event keyword) + "Return true if key-event has been defined to have Keyword as its + logical key-event. The relation between logical and real key-events + is defined by using SETF on LOGICAL-KEY-EVENT-P. If it is set to + true then calling LOGICAL-KEY-EVENT-P with the same key-event and + Keyword, will result in truth. Setting to false produces the opposite + result. See DEFINE-LOGICAL-KEY-EVENT and COMMAND-CASE." + (not (null (memq keyword (gethash key-event *real-to-logical-key-events*))))) + +;;; GET-LOGICAL-KEY-EVENT-DESC -- Internal ;;; -(defun logical-char= (character keyword) - "Return true if Character has been defined to have Keyword as its - logical character. The relation between logical and real characters - is defined by using Setf on Logical-Char=. If it is set to - true then calling Logical-Char= with the same Character and - Keyword, will result in truth. Setting to false produces the opposite - result. See Define-Logical-Character and Command-Case." - (not (null (memq keyword (gethash (char-upcase character) - *real-to-logical-characters*))))) - -;;; Get-Logical-Char-Desc -- Internal -;;; -;;; Return the descriptor for the logical character Kwd, or signal +;;; Return the descriptor for the logical key-event keyword, or signal ;;; an error if it isn't defined. ;;; -(defun get-logical-char-desc (kwd) - (let ((res (gethash kwd *logical-character-descriptors*))) +(defun get-logical-key-event-desc (keyword) + (let ((res (gethash keyword *logical-key-event-descriptors*))) (unless res - (error "~S is not a defined logical-character keyword." kwd)) + (error "~S is not a defined logical-key-event keyword." keyword)) res)) -;;; %Set-Logical-Char= -- Internal +;;; %SET-LOGICAL-KEY-EVENT-P -- Internal ;;; -;;; Add or remove a logical character link by adding to or deleting from +;;; Add or remove a logical key-event link by adding to or deleting from ;;; the list in the from-char hashtable and the descriptor. ;;; -(defun %set-logical-char= (character keyword new-value) - (let* ((character (char-upcase character)) - (entry (get-logical-char-desc keyword))) +(defun %set-logical-key-event-p (key-event keyword new-value) + (let ((entry (get-logical-key-event-desc keyword))) (cond (new-value - (pushnew keyword (gethash character *real-to-logical-characters*)) - (pushnew character (logical-character-descriptor-characters entry))) + (pushnew keyword (gethash key-event *real-to-logical-key-events*)) + (pushnew key-event (logical-key-event-descriptor-key-events entry))) (t - (setf (gethash character *real-to-logical-characters*) - (delete keyword (gethash character *real-to-logical-characters*))) - (setf (logical-character-descriptor-characters entry) - (delete keyword (logical-character-descriptor-characters entry)))))) + (setf (gethash key-event *real-to-logical-key-events*) + (delete keyword (gethash key-event *real-to-logical-key-events*))) + (setf (logical-key-event-descriptor-key-events entry) + (delete keyword (logical-key-event-descriptor-key-events entry)))))) new-value) -;;; Logical-Character-Documentation, Name, Characters -- Public +;;; LOGICAL-KEY-EVENT-DOCUMENTATION, NAME, KEY-EVENTS -- Public ;;; ;;; Grab the right field out of the descriptor and return it. ;;; -(defun logical-character-documentation (keyword) - "Return the documentation for the logical character Keyword." - (logical-character-descriptor-documentation (get-logical-char-desc keyword))) +(defun logical-key-event-documentation (keyword) + "Return the documentation for the logical key-event Keyword." + (logical-key-event-descriptor-documentation + (get-logical-key-event-desc keyword))) ;;; -(defun logical-character-name (keyword) - "Return the string name for the logical character Keyword." - (logical-character-descriptor-name (get-logical-char-desc keyword))) +(defun logical-key-event-name (keyword) + "Return the string name for the logical key-event Keyword." + (logical-key-event-descriptor-name (get-logical-key-event-desc keyword))) ;;; -(defun logical-character-characters (keyword) - "Return the list of characters for which Keyword is the logical character." - (logical-character-descriptor-characters (get-logical-char-desc keyword))) +(defun logical-key-event-key-events (keyword) + "Return the list of key-events for which Keyword is the logical key-event." + (logical-key-event-descriptor-key-events + (get-logical-key-event-desc keyword))) -;;; Define-Logical-Character -- Public +;;; DEFINE-LOGICAL-KEY-EVENT -- Public ;;; ;;; Make the entries in the two hashtables and the string-table. ;;; -(defun define-logical-character (name documentation) - "Define a logical character having the specified Name and Documentation. - See Logical-Char= and Command-Case." +(defun define-logical-key-event (name documentation) + "Define a logical key-event having the specified Name and Documentation. + See LOGICAL-KEY-EVENT-P and COMMAND-CASE." (check-type name string) (check-type documentation (or string function)) (let* ((keyword (string-to-keyword name)) - (entry (or (gethash keyword *logical-character-descriptors*) - (setf (gethash keyword *logical-character-descriptors*) - (make-logical-character-descriptor))))) - (setf (logical-character-descriptor-name entry) name) - (setf (logical-character-descriptor-documentation entry) documentation) - (setf (getstring name *logical-character-names*) keyword))) + (entry (or (gethash keyword *logical-key-event-descriptors*) + (setf (gethash keyword *logical-key-event-descriptors*) + (make-logical-key-event-descriptor))))) + (setf (logical-key-event-descriptor-name entry) name) + (setf (logical-key-event-descriptor-documentation entry) documentation) + (setf (getstring name *logical-key-event-names*) keyword))) -;;;; Some standard logical-characters: - -(define-logical-character "Forward Search" - "This character is used to indicate that a forward search should be made.") -(define-logical-character "Backward Search" - "This character is used to indicate that a backward search should be made.") -(define-logical-character "Recursive Edit" - "This character indicates that a recursive edit should be entered.") -(define-logical-character "Cancel" - "This character is used to cancel a previous character of input.") -(define-logical-character "Abort" - "This character is used to abort the command in progress.") -(define-logical-character "Exit" - "This character is used to exit normally the command in progress.") -(define-logical-character "Yes" - "This character is used to indicate a positive response.") -(define-logical-character "No" - "This character is used to indicate a negative response.") -(define-logical-character "Do All" - "This character means do it as many times as you can.") -(define-logical-character "Do Once" - "This character means, do it this time, then exit.") -(define-logical-character "Help" - "This character is used to ask for help.") -(define-logical-character "Confirm" - "This character is used to confirm some choice.") -(define-logical-character "Quote" - "This character is used to quote the next character of input.") -(define-logical-character "Keep" - "This character means exit but keep something around.") +;;;; Some standard logical-key-events: + +(define-logical-key-event "Forward Search" + "This key-event is used to indicate that a forward search should be made.") +(define-logical-key-event "Backward Search" + "This key-event is used to indicate that a backward search should be made.") +(define-logical-key-event "Recursive Edit" + "This key-event indicates that a recursive edit should be entered.") +(define-logical-key-event "Cancel" + "This key-event is used to cancel a previous key-event of input.") +(define-logical-key-event "Abort" + "This key-event is used to abort the command in progress.") +(define-logical-key-event "Exit" + "This key-event is used to exit normally the command in progress.") +(define-logical-key-event "Yes" + "This key-event is used to indicate a positive response.") +(define-logical-key-event "No" + "This key-event is used to indicate a negative response.") +(define-logical-key-event "Do All" + "This key-event means do it as many times as you can.") +(define-logical-key-event "Do Once" + "This key-event means, do it this time, then exit.") +(define-logical-key-event "Help" + "This key-event is used to ask for help.") +(define-logical-key-event "Confirm" + "This key-event is used to confirm some choice.") +(define-logical-key-event "Quote" + "This key-event is used to quote the next key-event of input.") +(define-logical-key-event "Keep" + "This key-event means exit but keep something around.") @@ -697,16 +701,18 @@ (get-output-stream-string s)) (let ((char (car chars))) (if (characterp char) - (print-pretty-character char s) - (do ((chars (logical-character-characters char) (cdr chars))) - ((null chars)) - (print-pretty-character (car chars) s) - (unless (null (cdr chars)) + (write-char char s) + (do ((key-events + (logical-key-event-key-events char) + (cdr key-events))) + ((null key-events)) + (ext:print-pretty-key (car key-events) s) + (unless (null (cdr key-events)) (write-string ", " s)))) (unless (null (cdr chars)) (write-string ", " s))))) -;;; Command-Case-Help -- Internal +;;; COMMAND-CASE-HELP -- Internal ;;; ;;; Print out a help message derived from the options in a ;;; random-typeout window. @@ -721,11 +727,8 @@ ((null o)) (let ((string (chars-to-string (caar o)))) (declare (simple-string string)) - (cond ((= (length string) 1) - (write-char (char string 0) s) - (write-string " - " s) - (write-line (cdar o) s)) - (t - (write-line string s) - (write-string " - " s) - (write-line (cdar o) s)))))))) + (if (= (length string) 1) + (write-char (char string 0) s) + (write-line string s)) + (write-string " - " s) + (write-line (cdar o) s)))))) diff --git a/hemlock/echocoms.lisp b/hemlock/echocoms.lisp index 47ea1d663..ab47e05fe 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."))))) @@ -212,6 +215,7 @@ "Pop the *echo-area-history* ring buffer." (let ((length (ring-length *echo-area-history*)) (p (or p 1))) + (declare (simple-string current)) (when (zerop length) (editor-error)) (cond ((eq (last-command-type) :echo-history) diff --git a/hemlock/filecoms.lisp b/hemlock/filecoms.lisp index e7f76abe0..554a7217a 100644 --- a/hemlock/filecoms.lisp +++ b/hemlock/filecoms.lisp @@ -369,13 +369,13 @@ :key #'buffer-pathname :test #'equal))) (cond ((not found) (let* ((name (pathname-to-buffer-name trial-pathname)) - (found (getstring name *buffer-names*)) - (use (if found + (buffer (getstring name *buffer-names*)) + (use (if buffer (prompt-for-buffer :prompt "Buffer to use: " :help "Buffer name in use; give another buffer name, or confirm to reuse." - :default found :must-exist nil) + :default buffer :must-exist nil) (make-buffer name))) (buffer (if (stringp use) (make-buffer use) use))) (when (and (buffer-modified buffer) @@ -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/files.lisp b/hemlock/files.lisp index 1c94de5aa..14167a352 100644 --- a/hemlock/files.lisp +++ b/hemlock/files.lisp @@ -137,6 +137,8 @@ (error "Could not set access code: ~S" (mach:get-unix-error-msg code))))))) +(proclaim '(special vm_page_size)) + (ext:def-c-variable "vm_page_size" int) (defvar *vm-page-size* (system:alien-access vm_page_size) diff --git a/hemlock/fill.lisp b/hemlock/fill.lisp index 6ee99082d..c609f764a 100644 --- a/hemlock/fill.lisp +++ b/hemlock/fill.lisp @@ -118,6 +118,7 @@ (defcommand "Auto Fill Linefeed" (p) "Does an immediate CRLF inserting Fill Prefix if it exists." "Does an immediate CRLF inserting Fill Prefix if it exists." + (declare (ignore p)) (let ((point (current-point))) (check-fill-prefix (value fill-prefix) (value fill-column) point) (%auto-fill-space point nil) @@ -125,7 +126,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))) @@ -137,6 +138,7 @@ followed by a newline." "Does an Auto Fill Space with a prefix argument of 0 followed by a newline." + (declare (ignore p)) (let ((point (current-point))) (check-fill-prefix (value fill-prefix) (value fill-column) point) (%auto-fill-space point nil) @@ -144,7 +146,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))) @@ -186,6 +188,7 @@ (defcommand "Fill Region" (p) "Fill text from point to mark." "Fill text from point to mark." + (declare (ignore p)) (let* ((region (current-region)) (prefix (value fill-prefix)) (column (if p (abs p) (value fill-column)))) diff --git a/hemlock/gosmacs.lisp b/hemlock/gosmacs.lisp index d65bc7ddc..056e5dddd 100644 --- a/hemlock/gosmacs.lisp +++ b/hemlock/gosmacs.lisp @@ -3,7 +3,7 @@ ;;; Stuff in this file provides some degree of upward compatibility ;;; for incurable Gosling Emacs users. ;;; -(in-package 'hemlock) +(in-package "HEMLOCK") (defcommand "Gosmacs Permute Characters" (p) "Transpose the two characters before the point." @@ -14,11 +14,11 @@ (editor-error "NIB You have addressed a character not in the buffer?")) (rotatef (previous-character m) (next-character m)))) -(bind-key "Gosmacs Permute Characters" #\control-t) -(bind-key "Kill Previous Word" #\meta-h) -(bind-key "Replace String" #\meta-r) -(bind-key "Query Replace" #\meta-q) -(bind-key "Fill Paragraph" #\meta-j) -(bind-key "Visit File" '#(#\control-x #\control-r)) -(bind-key "Find File" '#(#\control-x #\control-v)) -(bind-key "Insert File" '#(#\control-x #\control-i)) +(bind-key "Gosmacs Permute Characters" #k"control-t") +(bind-key "Kill Previous Word" #k"meta-h") +(bind-key "Replace String" #k"meta-r") +(bind-key "Query Replace" #k"meta-q") +(bind-key "Fill Paragraph" #k"meta-j") +(bind-key "Visit File" #k"control-x control-r") +(bind-key "Find File" #k"control-x control-v") +(bind-key "Insert File" #k"control-x control-i") diff --git a/hemlock/hemlock.log b/hemlock/hemlock.log index 395487657..e28ad8fb8 100644 --- a/hemlock/hemlock.log +++ b/hemlock/hemlock.log @@ -1,3 +1,318 @@ +.../systems-work/hemlock/keysym-defs.lisp, 04-Jul-90 12:14:09, Edit by Chiles. + Added a few key-event to character translations at the end of the file to + make quoting characters work better when running under X. + +/usr2/mbb/lisp/work/diredcoms.lisp, 02-Jul-90 10:12:28, Edit by Mbb. + Fixed a bug in "Dired" where it was incorrectly assuming that the current + buffer was a DIRED buffer. + +.../systems-work/hemlock/searchcoms.lisp, 27-Jun-90 18:27:38, Edit by Chiles. +.../systems-work/hemlock/kbdmac.lisp, 27-Jun-90 18:19:09, Edit by Chiles. + Fixed "Keyboard Macro Query" to realize the :bind arg to COMMAND-CASE is a + key-event, not a charcter. + +.../systems-work/hemlock/macros.lisp, 27-Jun-90 18:04:12, Edit by Chiles. + Fixed COMMAND-CASE to bind key-events, not characters. It also doesn't make + N calls to mapping functions everytime someone was to map one way or the + other. It also no longer makes erroneous assumptions about characters and + key-events having a one-to-one mapping. + +.../systems-work/hemlock/key-event.lisp, 27-Jun-90 17:34:57, Edit by Chiles. + Fixed bugs in character/key-event mapping that allowed bogus typed objects to + fall through as if they mapped to meaningful values. + +.../systems-work/hemlock/interp.lisp, 26-Jun-90 09:54:52, Edit by Chiles. + Fixed some documentation. + + Fixed a bug in KEY-TRANSLATION. Someone changed a type-spec from '(or + simple-vector null) to '(simple-vector null). + + Fixed a bug in TRANSLATE-KEY. It returned the wrong thing and by accident + didn't go into an infinite loop if there were any key translations to + multiple key-event keys. + + +.../systems-work/hemlock/echo.lisp, 25-Jun-90 11:44:05, Edit by Chiles. + Fixed default prompt of PROMPT-FOR-KEY-EVENT to be "Key-event: ", not + "Character: ". + +.../systems-work/hemlock/interp.lisp, 24-Jun-90 12:28:02, Edit by Chiles. + Removed silly KEYIFY definition, and I put Blaine's name on the file since he + modified half of the contents to get the new key tables stuff to work. + +.../systems-work/hemlock/input.lisp, 21-Jun-90 19:52:01, Edit by Chiles. + Added doc strings to public routines. Documented some code. Moved some + silly things around. + +.../systems-work/hemlock/srccom.lisp, 21-Jun-90 18:53:46, Edit by Chiles. +.../systems-work/hemlock/spellcoms.lisp, 21-Jun-90 18:52:56, Edit by Chiles. +.../systems-work/hemlock/macros.lisp, 21-Jun-90 18:51:19, Edit by Chiles. +.../systems-work/hemlock/filecoms.lisp, 21-Jun-90 18:49:14, Edit by Chiles. +.../systems-work/hemlock/doccoms.lisp, 21-Jun-90 18:45:55, Edit by Chiles. + Made COMMAND-CASE specify lowercase letters. + +.../systems-work/hemlock/key-event.lisp, 20-Jun-90 23:11:18, Edit by Chiles. + Fixed a bug in TRANSLATE-KEY-EVENT. + +.../systems-work/hemlock/bindings.lisp, 20-Jun-90 23:03:22, Edit by Chiles. + Bound #k"H-t" to "Illegal" in the echo area. This is normally bound to a + command that makes the current window display the most recently used + random-typeout buffer. + +.../systems-work/hemlock/macros.lisp, 20-Jun-90 20:45:07, Edit by Chiles. + Fixed an extra paren bug that prevented successful compilation. That's what + I get for Blaine's failure to use "Extract Form". + +.../systems-work/hemlock/lispmode.lisp, 20-Jun-90 20:47:57, Edit by Chiles. + Added "Extract Form", a more useful and intuitive and consistent command to + use instead of "Extract List" which is archaic, confusing, erroneously bound + by default, and bound to old Lisp ideals that lists are something to focus + on. + +.../hemlock/ts-buf.lisp, 20-Jun-90 17:40:51, Edit by Wlott. + Made typescript commands more robust in light of the possibility of being + executed while in a buffer other than the slave buffer. + +.../systems-work/hemlock/key-event.lisp, 20-Jun-90 17:00:33, Edit by Chiles. + Totally rewrote mouse translation code. Fixed multiple bugs MAKE-KEY-EVENT. + +.../systems-work/hemlock/macros.lisp, 20-Jun-90 13:55:48, Edit by Chiles. + Removed :character argument to COMMAND-CASE. Stopped case-folding and + eliminated variables used for that. + +.../systems-work/hemlock/fill.lisp, 16-Jun-90 14:07:48, Edit by Chiles. + Fixed "Auto Fill Linefeed" and "Auto Fill Return" to use #k syntax instead of + characters for keys. + +.../systems-work/hemlock/key-event.lisp, 16-Jun-90 13:59:23, Edit by Chiles. + Added missing exports. + + Fixed a couple bugs with DEFINE-KEY-EVENT-MODIFIER. It was using EQL to + compare strings. Stuck an UNWIND-PROTECT in there to keep things consistent. + Added restart for already defined modifiers allowing the user to go on + blowing it off; this helps reloading the file. + + +.../systems-work/hemlock/echo.lisp, 16-Jun-90 11:11:17, Edit by Chiles. + Fixed two GET-KEY-EVENT calls to ignore abort attempts in PROMPT-FOR-KEY + and PROMPT-FOR-KEY-EVENT. + +.../systems-work/hemlock/keysym-defs.lisp, 15-Jun-90 18:17:38, Edit by Chiles. + This file used to be called keytrandefs.lisp. + +.../systems-work/hemlock/key-event.lisp, 15-Jun-90 18:34:10, Edit by Chiles. + This file used to be called keytran.lisp. It now implements key-events in + the "EXTENSIONS" package. + +.../systems-work/hemlock/bit-screen.lisp, 14-Jun-90 14:28:58, Edit by Chiles. + Replaced calls to EXT:TRANSLATE-CHARACTER and EXT:TRANSLATE-MOUSE-CHARACTER + with EXT:TRANSLATE-KEY-EVENT and EXT:TRANSLATE-MOUSE-KEY-EVENT. + +.../systems-work/hemlock/shell.lisp, 15-Jun-90 16:27:42, Edit by Chiles. + Picked up Blaine's new shell hacks and documented them. Added "Current + Shell" and "Ask about Old Shells" variables. Changed "Shell" to be more like + "Select Slave" and wrote "Shell Command Line in Buffer". + +/usr2/mbb/lisp/work/doccoms.lisp, 14-Jun-90 21:19:46, Edit by Mbb. + Made a quoted list of #k mouse-keys be a call to LIST on the mouse-keys + instead so they would get evaluated. + +/usr2/mbb/lisp/work/input.lisp, 12-Jun-90 21:00:12, Edit by Mbb. + input.lisp is a new file. It contains code to implement input to + hemlock. Similar code previously resided in rompsite.lisp + +/usr2/mbb/lisp/work/icom.lisp, 12-Jun-90 16:15:00, Edit by Mbb. +/usr2/mbb/lisp/work/gosmacs.lisp, 12-Jun-90 16:15:00, Edit by Mbb. + Changed BIND-KEY calls to use #k format instead of characters. + +.../systems-work/hemlock/filecoms.lisp, 13-Jun-90 15:17:06, Edit by Chiles. + Wrote "Go to One Window" which makes a default initial window and deletes all + other windows. This is useful with losing window managers like twm, and it + is useful in case you ever resize or move the main Hemlock window which + happens by accident to some people. + +/usr2/mbb/lisp/work/keytran.lisp, 13-Jun-90 14:01:58, Edit by Mbb. + Changed all the BIND-KEY forms in this file to use #k format. + +/usr2/mbb/lisp/work/files.lisp, 12-Jun-90 10:26:58, Edit by Mbb. + Inserted the form (proclaim '(special vm_page_size)) so the compiler + wouldn't whine about vm_page_size not being declared or bound. + +/usr2/mbb/lisp/work/buffer.lisp, 11-Jun-90 11:58:39, Edit by Mbb. + Modified DEFMODE -- The default mode-bindings slot is now a hash-table + whereas it used to be a key-table. Did the same for buffer-bindings in + MAKE-BUFFER. + +/usr2/mbb/lisp/work/keytrandefs.lisp, 11-Jun-90 13:17:59, Edit by Mbb. + Made all calls to "EXTENSIONS" use an ext: prefix. + +/usr2/mbb/lisp/work/scribe.lisp, 08-Jun-90 17:33:31, Edit by Mbb. +/usr2/mbb/lisp/work/register.lisp, 08-Jun-90 17:29:23, Edit by Mbb. +/usr2/mbb/lisp/work/interp.lisp, 08-Jun-90 17:27:44, Edit by Mbb. + Changed all calls to PRINT-PRETTY-CHARACTER to calls to + PRINT-PRETTY-KEY-EVENT. + +/usr2/mbb/lisp/work/kbdmac.lisp, 08-Jun-90 17:25:50, Edit by Mbb. + Made all calls to SUB-PRINT-KEY be calls to PRINT-PRETTY-KEY. + +/usr2/mbb/lisp/work/doccoms.lisp, 08-Jun-90 17:15:46, Edit by Mbb. + Removed SUB-PRINT-KEY in favor of PRINT-PRETTY-KEY. + +/usr2/mbb/lisp/work/searchcoms.lisp, 08-Jun-90 14:38:55, Edit by Mbb. +/usr2/mbb/lisp/work/overwrite.lisp, 08-Jun-90 14:38:38, Edit by Mbb. +/usr2/mbb/lisp/work/morecoms.lisp, 08-Jun-90 14:37:43, Edit by Mbb. +/usr2/mbb/lisp/work/completion.lisp, 08-Jun-90 14:37:10, Edit by Mbb. +/usr2/mbb/lisp/work/command.lisp, 08-Jun-90 14:36:12, Edit by Mbb. + Changed all calls to TEXT-CHARACTER to calls to KEY-EVENT-CHAR. + +/usr2/mbb/lisp/work/rompsite.lisp, 08-Jun-90 12:15:17, Edit by Mbb. +/usr2/mbb/lisp/work/termcap.lisp, 08-Jun-90 12:15:17, Edit by Mbb. + Commented out CL-TERMCAP-CHAR as it is no longer needed. + GET-TERMCAP-STRING-CHAR does the conversion to a character now. + +/usr2/mbb/lisp/work/doccoms.lisp, 08-Jun-90 11:08:09, Edit by Mbb. + Removed from GET-MOUSE-COMMANDS a call to MAKE-CHAR in favor of + MAKE-KEY-EVENT and also fixed a list to use the new #k"foo" format. + +/usr2/mbb/lisp/work/bindings.lisp, 08-Jun-90 10:44:49, Edit by Mbb. + Chnaged all bindings to #k"foo" format. + +/usr2/mbb/lisp/work/charmacs.lisp, 07-Jun-90 14:44:36, Edit by Mbb. + Removed the declaration of the constant all-bit-names, as bit names are + no longer supported in Common Lisp. + +/usr2/mbb/lisp/work/charmacs.lisp, 07-Jun-90 14:41:23, Edit by Mbb. + Changed ALPHA-CHAR-LOOP and DO-ALPHA-CHARS to ALPHA-KEY-EVENTS-LOOP and + DO-ALPHA-KEY-EVENTS respectively. + +/usr2/mbb/lisp/work/tty-display.lisp, 06-Jun-90 10:38:07, Edit by Mbb. +/usr2/mbb/lisp/work/searchcoms.lisp, 06-Jun-90 10:36:39, Edit by Mbb. +/usr2/mbb/lisp/work/searchcoms.lisp, 06-Jun-90 10:21:58, Edit by Mbb. +/usr2/mbb/lisp/work/rompsite.lisp, 06-Jun-90 10:09:11, Edit by Mbb. +/usr2/mbb/lisp/work/morecoms.lisp, 06-Jun-90 10:16:52, Edit by Mbb. +/usr2/mbb/lisp/work/mh.lisp, 06-Jun-90 10:14:12, Edit by Mbb. +/usr2/mbb/lisp/work/doccoms.lisp, 06-Jun-90 10:04:45, Edit by Mbb. +/usr2/mbb/lisp/work/macros.lisp, 05-Jun-90 15:11:03, Edit by Mbb. +/usr2/mbb/lisp/work/kbdmac.lisp, 05-Jun-90 15:08:37, Edit by Mbb. +/usr2/mbb/lisp/work/interp.lisp, 05-Jun-90 11:02:59, Edit by Mbb. +/usr2/mbb/lisp/work/echo.lisp, 05-Jun-90 10:58:55, Edit by Mbb. +/usr2/mbb/lisp/work/doccoms.lisp, 05-Jun-90 15:05:40, Edit by Mbb. +/usr2/mbb/lisp/work/command.lisp, 05-Jun-90 15:02:21, Edit by Mbb. + Fixed all references to *editor-input*. + +/usr2/mbb/lisp/work/main.lisp, 06-Jun-90 10:07:41, Edit by Mbb. + *editor-input* used to be exported from this file, event though it is + also exported in input.lisp. Removed export from main.lisp. + +/usr2/mbb/lisp/work/rompsite.lisp, 05-Jun-90 14:31:55, Edit by Mbb. + Changed reference to *character-history* in SITE-INIT to + *key-event-history*. + +/usr2/mbb/lisp/work/mh.lisp, 05-Jun-90 14:30:28, Edit by Mbb. + Changed a reference to *character-history* to *key-event-history*. + +/usr2/mbb/lisp/work/main.lisp, 05-Jun-90 14:27:23, Edit by Mbb. + Removed export of *character-history* from this file in favor of putting + it in input.lisp and changing the name to *key-event-history*. + +/usr2/mbb/lisp/work/doccoms.lisp, 05-Jun-90 14:19:41, Edit by Mbb. + Made "What Lossage" command reference *key-event-history* instead of + *character-history*. + +/usr2/mbb/lisp/work/streams.lisp, 05-Jun-90 14:10:43, Edit by Mbb. + Made KBDMAC-GET use *last-key-event-typed* instead of + *last-character-typed*. Also changed stream definition of kbdmac-stream + to coincide with the new editor-input like streams. + +/usr2/mbb/lisp/work/spellcoms.lisp, 05-Jun-90 14:08:57, Edit by Mbb. + Made SUB-CORRECT-LAST-MISSPELLED-WORD work with *last-key-event-typed*. + +/usr2/mbb/lisp/work/scribe.lisp, 05-Jun-90 14:07:23, Edit by Mbb. + Fixed "Scribe Insert bracket" to work with *last-key-event-typed*. + +/usr2/mbb/lisp/work/rompsite.lisp, 05-Jun-90 13:59:46, Edit by Mbb. + Removed all Input queue management and Random Typeout input routines and + put them in a input.lisp, a new hemlock file. + +/usr2/mbb/lisp/work/rompsite.lisp, 05-Jun-90 13:45:23, Edit by Mbb. + Changed DEFVAR of *last-character-typed* to *last-key-event-typed*. Also + fixed setting of *last-character-typed* in DQ-EVENT. For some reason, + *last-character-typed* was exported from both main.lisp and + rompsite.lisp. This remains under the new name. + +/usr2/mbb/lisp/work/overwrite.lisp, 05-Jun-90 13:43:23, Edit by Mbb. + Made "Self Overwrite" use *last-key-event-typed* instead of + *last-character-typed*. + +/usr2/mbb/lisp/work/morecoms.lisp, 05-Jun-90 13:41:58, Edit by Mbb. + Made "Self Insert Caps Lock" deal with *last-key-event-typed* instead of + *last-character-typed*. + +/usr2/mbb/lisp/work/main.lisp, 05-Jun-90 13:40:48, Edit by Mbb. + Changed export of *last-character-typed* to *last-key-event-typed*. + +/usr2/mbb/lisp/work/kbdmac.lisp, 05-Jun-90 13:37:38, Edit by Mbb. + Made DEFAULT-KBDMAC-TRANSFORM and SELF-INSERT-KBDMAC-TRANSFORM use + *last-key-event-typed* instead of *last-character-typed*. + +/usr2/mbb/lisp/work/echocoms.lisp, 05-Jun-90 13:34:52, Edit by Mbb. + Made "Complete Field" work with *last-key-event-typed*. +/usr2/mbb/lisp/work/completion.lisp, 05-Jun-90 13:28:07, Edit by Mbb. + Made "Completion Self Insert" deal with *last-key-event-typed* instead of + *last-character-typed*. + +/usr2/mbb/lisp/work/command.lisp, 05-Jun-90 13:24:55, Edit by Mbb. + Changed UNIVERSAL-ARGUMENT-LOOP to deal with *last-key-event-typed* + instead of *last-character-typed*. Also made "Self Insert" do the same. + +/usr2/mbb/lisp/work/spellcoms.lisp, 05-Jun-90 12:58:02, Edit by Mbb. + Changed calls to PROMPT-FOR-CHARACTER to calls to PROMPT-FOR-KEY-EVENT. + Since what we wanted was the number of the correction choice, simply wrap + a call to KEY-EVENT-CHAR around the PROMPT-FOR-KEY-EVENT. + +/usr2/mbb/lisp/work/scribe.lisp, 05-Jun-90 11:59:46, Edit by Mbb. + Made ADD-SCRIBE-DIRECTIVE and INSERT-SCRIBE-DIRECTIVE use PROMPT-FOR-KEY + instead of PROMPT-FOR-CHARACTER. They used to HASH on the result of + PROMPT-FOR-CHARACTER, so key-events will work just as well. + +/usr2/mbb/lisp/work/scribe.lisp, 05-Jun-90 11:59:46, Edit by Mbb. + Changed all top-level ADD-SCRIBE-DIRECTIVE-COMMAND calls to use #k syntax + when binding dispatches. + +/usr2/mbb/lisp/work/struct.lisp, 05-Jun-90 11:08:20, Edit by Mbb. + Changed DEFSETF for %SET-LOGICAL-CHAR= to %SET-LOGICAL-KEY-EVENT-P in + order to maintain consistency. + +/usr2/mbb/lisp/work/macros.lisp, 05-Jun-90 09:23:41, Edit by Mbb. + Fixed COMMAND-CASE to bind key-events instead of characters. + +/usr2/mbb/lisp/work/register.lisp, 05-Jun-90 09:31:41, Edit by Mbb. + Made PROMPT-FOR-REGISTER return a key-event instead of a character. The + rest of the code code just hashes on what PROMPT-FOR-REGISTER returns, so + since key-events are unique, nothing else had to be changed. + +/usr2/mbb/lisp/work/keytrandefs.lisp, 04-Jun-90 13:16:13, Edit by Mbb. + Completely changed this file to conform to new key syntax. + +/usr2/mbb/lisp/work/charmacs.lisp, 04-Jun-90 13:10:55, Edit by Mbb. + Removed all pushes into lisp::char-name-alist. + +.../systems-work/hemlock/completion.lisp, 29-May-90 13:54:48, Edit by Chiles. + Changed test in DO-COMPLETION to explicitly test for uppercase characters. + Testing for lowercase characters caused ID's to be uppercased when they began + with non-alphabetic characters (such as digit-chars). + +.../systems-work/hemlock/bindings.lisp, 21-May-90 10:22:28, Edit by Chiles. +.../systems-work/hemlock/morecoms.lisp, 21-May-90 10:19:13, Edit by Chiles. + Added "CAPS-LOCK" mode, "Caps Lock Mode" and "Caps Lock Self Insert". + + Added bindings for lowercase letters. + + +.../systems-work/hemlock/bindings.lisp, 21-May-90 10:14:10, Edit by Chiles. +.../systems-work/hemlock/diredcoms.lisp, 21-May-90 10:03:16, Edit by Chiles. + Wrote "Dired Up Directory" and added binding to #\^ in "Dired" mode. + .../systems-work/hemlock/diredcoms.lisp, 08-May-90 15:38:28, Edit by Chiles. Fixed :help string in file prompt for "Delete File". diff --git a/hemlock/icom.lisp b/hemlock/icom.lisp index e74acd50f..a5a106466 100644 --- a/hemlock/icom.lisp +++ b/hemlock/icom.lisp @@ -62,4 +62,4 @@ 1 :left-inserting))) -(bind-key "Start Italic Comment" #\; :mode "Italic") +(bind-key "Start Italic Comment" #k";" :mode "Italic") diff --git a/hemlock/interp.lisp b/hemlock/interp.lisp index 194b4018a..2cbbb2037 100644 --- a/hemlock/interp.lisp +++ b/hemlock/interp.lisp @@ -8,7 +8,7 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -;;; Written by Rob MacLachlan +;;; Written by Rob MacLachlan and Blaine Burks. ;;; ;;; This file contains the routines which define hemlock commands and ;;; the command interpreter. @@ -32,64 +32,37 @@ ;;;; Key Tables: ;;; ;;; A key table provides a way to translate a sequence of characters to some -;;; lisp object. It is currently represented by a tree of vectors, with -;;; alternating levels being indexed by the bits and code. We wrap a Key-Table -;;; structure around the table so that we can discriminate bewteen a key table -;;; and a value. -;;; +;;; lisp object. It is currently represented by a tree of hash-tables, where +;;; each level is a hashing from a key to either another hash-table or a value. -(defstruct (key-table - (:print-function - (lambda (x stream y) - (declare (ignore x y)) - (write-string "#<Key-Table>" stream)))) - (table (make-array command-char-bits-limit :initial-element nil) - :type simple-vector)) - -;;; GET-TABLE-ENTRY -- Internal -;;; -;;; Return the value found by walking down a tree of command tables as -;;; specified by a key. If no such entry return NIL. +;;; GET-TABLE-ENTRY returns the value at the end of a series of hashings. For +;;; our purposes it is presently used to look up commands and key-translations. ;;; (defun get-table-entry (table key) - (let ((current table)) - (dotimes (i (length key) current) - (unless (key-table-p current) (return nil)) - (let* ((char (aref key i)) - (bits-vec (key-table-table current)) - (code-vec (svref bits-vec (key-char-bits char)))) - (unless code-vec (return nil)) - (setq current (svref code-vec (key-char-code char))))))) - + (let ((foo nil)) + (dotimes (i (length key) foo) + (let ((key-event (aref key i))) + (setf foo (gethash key-event table)) + (unless (hash-table-p foo) (return foo)) + (setf table foo))))) -;;; SET-TABLE-ENTRY -- Internal -;;; -;;; Set the entry for Key in Table to Val, creating new key tables as -;;; needed. +;;; SET-TABLE-ENTRY sets the entry for key in table to val, creating new +;;; tables as needed. If val is nil, then use REMHASH to remove this element +;;; from the hash-table. ;;; (defun set-table-entry (table key val) - (do ((keylast (1- (length key))) - (index 0 (1+ index)) - (current table)) - (()) - (let* ((char (aref key index)) - (bits (key-char-bits char)) - (code (key-char-code char)) - (bits-vec (key-table-table current)) - (code-vec (or (svref bits-vec bits) - (setf (svref bits-vec bits) - (make-array command-char-code-limit - :initial-element nil)))) - (next (svref code-vec code))) - (cond ((= index keylast) - (setf (svref code-vec code) val) - (return val)) - ((key-table-p next) - (setq current next)) - (t - (setq current (make-key-table)) - (setf (svref code-vec code) current)))))) + (dotimes (i (1- (length key))) + (let* ((key-event (aref key i)) + (foo (gethash key-event table))) + (if (hash-table-p foo) + (setf table foo) + (let ((new-table (make-hash-table))) + (setf (gethash key-event table) new-table) + (setf table new-table))))) + (if (null val) + (remhash (aref key (1- (length key))) table) + (setf (gethash (aref key (1- (length key))) table) val))) ;;;; Key Translation: @@ -98,7 +71,7 @@ ;;; integer, then it is prefix bits to be OR'ed with the next character. If it ;;; is a key, then we translate to that key. -(defvar *key-translations* (make-key-table)) +(defvar *key-translations* (make-hash-table)) (defvar *translate-key-temp* (make-array 10 :fill-pointer 0 :adjustable t)) @@ -110,7 +83,8 @@ ;;; key ends in the prefix of a translation, we just return that part ;;; untranslated and return the second value true. ;;; -(defun translate-key (key &optional (result (make-array 4 :fill-pointer 0 +(defun translate-key (key &optional (result (make-array (length key) + :fill-pointer 0 :adjustable t))) (let ((key-len (length key)) (temp *translate-key-temp*) @@ -121,83 +95,75 @@ (setf (fill-pointer result) 0) (loop (when (= try-pos key-len) (return)) - (let ((ch (aref key try-pos))) - (vector-push-extend (make-char ch (logior (char-bits ch) prefix)) - temp) - (setq prefix 0)) + (let ((key-event (aref key try-pos))) + (vector-push-extend + (ext:make-key-event key-event (logior (ext:key-event-bits key-event) + prefix)) + temp) + (setf prefix 0)) (let ((entry (get-table-entry *key-translations* temp))) - (unless (key-table-p entry) - (etypecase entry - (null - (vector-push-extend (aref temp 0) result) - (incf start)) - (simple-vector - (dotimes (i (length entry)) - (vector-push-extend (aref entry i) result)) - (setq start (1+ try-pos))) - (integer - (setq start (1+ try-pos)) - (when (= start key-len) (return)) - (setq prefix (logior entry prefix)))) - (setq try-pos start) - (setf (fill-pointer temp) 0)))) - + (cond ((hash-table-p entry) + (incf try-pos)) + (t + (etypecase entry + (null + (vector-push-extend (aref temp 0) result) + (incf start)) + (simple-vector + (dotimes (i (length entry)) + (vector-push-extend (aref entry i) result)) + (setf start (1+ try-pos))) + (integer + (setf start (1+ try-pos)) + (when (= start key-len) (return)) + (setf prefix (logior entry prefix)))) + (setq try-pos start) + (setf (fill-pointer temp) 0))))) (dotimes (i (length temp)) (vector-push-extend (aref temp i) result)) (values result (not (zerop (length temp)))))) -;;; KEY-TRANSLATION -- Public -;;; -;;; Set the value, dealing with translating to and from symbolic bit names. +;;; KEY-TRANSLATION -- Public. ;;; (defun key-translation (key) "Return the key translation for Key, or NIL if there is none. If Key is a - prefix of a translation, then :Prefix is returned. Whenever Key appears as a - subsequence of a key argument to the binding manipulation functions, that - portion will be replaced with the translation. A key translation may also be - a list (:Bits {Bit-Name}*). In this case, the named bits will be set in the - next character in the key being translated." + prefix of a translation, then :Prefix is returned. Whenever Key appears as a + subsequence of a key argument to the binding manipulation functions, that + portion will be replaced with the translation. A key translation may also be + a list (:Bits {Bit-Name}*). In this case, the named bits will be set in the + next character in the key being translated." (let ((entry (get-table-entry *key-translations* (crunch-key key)))) (etypecase entry - (key-table :prefix) + (hash-table :prefix) ((or simple-vector null) entry) (integer - (let ((ch (make-char #\? entry)) - (res ())) - (dolist (bit all-bit-names) - (when (char-bit ch bit) - (push bit res))) - (cons :bits res)))))) - -(defsetf key-translation %set-key-translation - "Set the key translation for a key. If set to null, deletes any - translation.") + (cons :bits (ext:key-event-bits-modifiers entry)))))) ;;; %SET-KEY-TRANSLATION -- Internal ;;; -;;; Setf inverse for Key-Translation. -;;; (defun %set-key-translation (key new-value) - (let ((entry (cond ((and (consp new-value) (eq (first new-value) :bits)) - (let ((res #\?)) - (dolist (bit (rest new-value) (char-bits res)) - (setf (char-bit res bit) t)))) - ((null new-value) new-value) - (t - (crunch-key new-value))))) + (let ((entry (cond ((and (consp new-value) (eq (car new-value) :bits)) + (apply #'ext:make-key-event-bits (cdr new-value))) + (new-value (crunch-key new-value)) + (t new-value)))) (set-table-entry *key-translations* (crunch-key key) entry) new-value)) +;;; +(defsetf key-translation %set-key-translation + "Set the key translation for a key. If set to null, deletes any + translation.") + ;;;; Interface Utility Functions: -(defvar *global-command-table* (make-key-table) +(defvar *global-command-table* (make-hash-table) "The command table for global key bindings.") ;;; GET-RIGHT-TABLE -- Internal ;;; -;;; Return a key-table depending on "kind" and checking for errors. +;;; Return a hash-table depending on "kind" and checking for errors. ;;; (defun get-right-table (kind where) (case kind @@ -216,37 +182,36 @@ (t (error "~S is not a valid binding type." kind)))) -;;; CRUNCH-KEY -- Internal +;;; CRUNCH-KEY -- Internal. ;;; -;;; Take a key in one of the various specifications and turn it -;;; into the standard one: a simple-vector of characters. +;;; Take a key in one of the various specifications and turn it into the +;;; standard one: a simple-vector of characters. ;;; (defun crunch-key (key) (typecase key - (character (vector key)) - ((or list vector) + (ext:key-event (vector key)) + ((or list vector) ;List thrown in gratuitously. (when (zerop (length key)) - (error "Zero length key is illegal.")) - (unless (every #'characterp key) - (error "Key ~S has a non-character element." key)) + (error "A zero length key is illegal.")) + (unless (every #'ext:key-event-p key) + (error "A Key ~S must contain only key-events." key)) (coerce key 'simple-vector)) (t - (error "Key ~S is not a character or sequence." key)))) + (error "Key ~S is not a key-event or sequence of key-events." key)))) + ;;;; Exported Primitives: (proclaim '(special *command-names*)) -;;; BIND-KEY -- Public -;;; -;;; Put the command specified in the correct key table. +;;; BIND-KEY -- Public. ;;; (defun bind-key (name key &optional (kind :global) where) "Bind a Hemlock command to some key somewhere. Name is the string name - of a Hemlock command, Key is either a character or a vector of characters. - Kind is one of :Global, :Mode or :Buffer, Where is the mode name or buffer - concerned. Kind defaults to :Global." + of a Hemlock command, Key is either a key-event or a vector of key-events. + Kind is one of :Global, :Mode or :Buffer, and where is the mode name or + buffer concerned. Kind defaults to :Global." (let ((cmd (getstring name *command-names*)) (table (get-right-table kind where)) (key (copy-seq (translate-key (crunch-key key))))) @@ -264,10 +229,9 @@ ;;; Stick NIL in the key table specified. ;;; (defun delete-key-binding (key &optional (kind :global) where) - "Remove a Hemlock key binding somewhere. Name is the string name of - a Hemlock command, Key is either a character or a vector of - characters. Kind is one of :Global, :Mode or :Buffer, Where is the - mode name or buffer concerned. Kind defaults to :Global." + "Remove a Hemlock key binding somewhere. Key is either a key-event or a + vector of key-events. Kind is one of :Global, :Mode or :Buffer, andl where + is the mode name or buffer concerned. Kind defaults to :Global." (set-table-entry (get-right-table kind where) (translate-key (crunch-key key)) nil)) @@ -295,17 +259,14 @@ (return (values res (nreverse t-bindings))))))))))) -;;; GET-COMMAND -- Public -;;; -;;; Look up the key binding, checking for :Prefix. +;;; GET-COMMAND -- Public. ;;; (defun get-command (key &optional (kind :global) where) "Return the command object for the command bound to key somewhere. - If key is not bound return NIL, if Key is a prefix of a key-binding - then reutrn :Prefix. Name is the string name of a Hemlock command, - Key is either a character or a vector of characters. Kind is one of - :Global, :Mode or :Buffer, Where is the mode name or buffer - concerned. Kind defaults to :Global." + If key is not bound, return nil. Key is either a key-event or a vector of + key-events. If key is a prefix of a key-binding, then return :prefix. + Kind is one of :global, :mode or :buffer, and where is the mode name or + buffer concerned. Kind defaults to :Global." (multiple-value-bind (key prefix-p) (translate-key (crunch-key key)) (let ((entry (if (eq kind :current) @@ -314,45 +275,32 @@ (etypecase entry (null (if prefix-p :prefix nil)) (command entry) - (key-table :prefix))))) + (hash-table :prefix))))) +(defvar *map-bindings-key* (make-array 5 :adjustable t :fill-pointer 0)) -;;; MAP-BINDINGS -- Public -;;; -;;; map over a key table. -;;; -(defun map-bindings (fun kind &optional where) - "Map Fun over the bindings in some place. The function is passed the - Key and the command to which it is bound." - (sub-map-bindings fun (key-table-table (get-right-table kind where)) '#())) +;;; MAP-BINDINGS -- Public. ;;; -(defun sub-map-bindings (fun tab key) - (declare (simple-vector tab key)) - (let ((key (concatenate 'simple-vector key '#(#\space))) - (index (length key))) - (dotimes (bits command-char-bits-limit) - (let ((vec (svref tab bits))) - (when vec - (dotimes (code command-char-code-limit) - (setf (svref key index) (code-char code bits)) - (let ((val (svref vec code))) - (cond ((null val)) - ((commandp val) - (funcall fun key val)) - (t - (sub-map-bindings fun (key-table-table val) - key)))))))))) +(defun map-bindings (function kind &optional where) + "Map function over the bindings in some place. The function is passed the + key and the command to which it is bound." + (labels ((mapping-fun (hash-key hash-value) + (vector-push-extend hash-key *map-bindings-key*) + (etypecase hash-value + (command (funcall function *map-bindings-key* hash-value)) + (hash-table (maphash #'mapping-fun hash-value))) + (decf (fill-pointer *map-bindings-key*)))) + (setf (fill-pointer *map-bindings-key*) 0) + (maphash #'mapping-fun (get-right-table kind where)))) - -;;; MAKE-COMMAND -- Public +;;; MAKE-COMMAND -- Public. ;;; -;;; If the command is already defined then alter the command object, -;;; otherwise make a new command object and enter it into the -;;; *command-names*. +;;; If the command is already defined, then alter the command object; +;;; otherwise, make a new command object and enter it into the *command-names*. ;;; (defun make-command (name documentation function) "Create a new Hemlock command with Name and Documentation which is - implemented by calling the function-value of the symbol Function" + implemented by calling the function-value of the symbol Function" (let ((entry (getstring name *command-names*))) (cond (entry @@ -364,9 +312,7 @@ (internal-make-command name documentation function)))))) -;;; COMMAND-NAME, %SET-COMMAND-NAME -- Public -;;; -;;; Filter the slot, updating *command-names* if it is set. +;;; COMMAND-NAME, %SET-COMMAND-NAME -- Public. ;;; (defun command-name (command) "Returns the string which is the name of Command." @@ -381,33 +327,21 @@ (setf (command-%name command) new-name)) -;;; COMMAND-BINDINGS -- Public +;;; COMMAND-BINDINGS -- Public. ;;; -;;; Check that all the supposed bindings really exists. Bindings which +;;; Check that all the supposed bindings really exists. Bindings which ;;; were once made may have been overwritten. It is easier to filter ;;; out bogus bindings here than to catch all the cases that can make a ;;; binding go away. ;;; -(defun binding= (b1 b2) - (and (eq (second b1) (second b2)) - (equal (third b1) (third b2)) - (let* ((k1 (first b2)) - (l1 (length k1)) - (k2 (first b1))) - (declare (simple-vector k1 k2)) - (if (= l1 (length k2)) - (dotimes (i l1 t) - (when (char/= (svref k1 i) (svref k2 i)) - (return nil))))))) -;;; (defun command-bindings (command) "Return a list of lists of the form (key kind where) describing - all the places there Command is bound." + all the places where Command is bound." (check-type command command) - (let (res) - (declare (list res)) + (let (result) + (declare (list result)) (dolist (place (command-%bindings command)) - (let ((tab (case (cadr place) + (let ((table (case (cadr place) (:global *global-command-table*) (:mode (let ((m (getstring (caddr place) *mode-names*))) @@ -415,10 +349,11 @@ (t (when (memq (caddr place) *buffer-list*) (buffer-bindings (caddr place))))))) - (when (and tab (eq (get-table-entry tab (car place)) command) - (not (find place res :test #'binding=))) - (push place res)))) - res)) + (when (and table + (eq (get-table-entry table (car place)) command) + (not (member place result :test #'equalp))) + (push place result)))) + result)) (defvar *last-command-type* () @@ -451,8 +386,7 @@ ;;; ;;; (defun prefix-argument () - "Return the current value of the prefix argument. This can be set - with Setf." + "Return the current value of prefix argument. This can be set with SETF." *prefix-argument*) ;;; %SET-PREFIX-ARGUMENT -- Internal @@ -506,40 +440,38 @@ (unless (or (zerop (length cmd)) (not (value ed::key-echo-delay))) (editor-sleep (value ed::key-echo-delay)) - (unless (listen *editor-input*) + (unless (listen-editor-input *editor-input*) (clear-echo-area) (dotimes (i (length cmd)) - (print-pretty-character (aref cmd i) *echo-area-stream*) + (ext:print-pretty-key (aref cmd i) *echo-area-stream*) (write-char #\space *echo-area-stream*))))) - (vector-push-extend (read-char *editor-input*) cmd) - + (vector-push-extend (get-key-event *editor-input*) cmd) (multiple-value-bind (trans-result prefix-p) (translate-key cmd trans) (multiple-value-bind (res t-bindings) (get-current-binding trans-result) - (cond - ((commandp res) - (let ((punt t)) - (catch 'command-loop-catcher - (dolist (c t-bindings) - (funcall *invoke-hook* c *prefix-argument*)) - (funcall *invoke-hook* res *prefix-argument*) - (setf punt nil)) - (when punt (invoke-hook ed::command-abort-hook))) - (if *command-type-set* - (setq *command-type-set* nil) - (setq *last-command-type* nil)) - (if *prefix-argument-supplied* - (setq *prefix-argument-supplied* nil) - (setq *prefix-argument* nil)) - (setf (fill-pointer cmd) 0)) - ((null res) - (unless prefix-p - (beep) - (setq *prefix-argument* nil) - (setf (fill-pointer cmd) 0))) - ((not (key-table-p res)) - (error "Bad thing in key table: ~S" res))))))))) + (etypecase res + (command + (let ((punt t)) + (catch 'command-loop-catcher + (dolist (c t-bindings) + (funcall *invoke-hook* c *prefix-argument*)) + (funcall *invoke-hook* res *prefix-argument*) + (setf punt nil)) + (when punt (invoke-hook ed::command-abort-hook))) + (if *command-type-set* + (setq *command-type-set* nil) + (setq *last-command-type* nil)) + (if *prefix-argument-supplied* + (setq *prefix-argument-supplied* nil) + (setq *prefix-argument* nil)) + (setf (fill-pointer cmd) 0)) + (null + (unless prefix-p + (beep) + (setq *prefix-argument* nil) + (setf (fill-pointer cmd) 0))) + (hash-table)))))))) ;;; EXIT-HEMLOCK -- Public diff --git a/hemlock/kbdmac.lisp b/hemlock/kbdmac.lisp index 775bfcd34..c97a20ae3 100644 --- a/hemlock/kbdmac.lisp +++ b/hemlock/kbdmac.lisp @@ -13,7 +13,8 @@ ;;; implementation dependant, but it uses some hooks in the stream ;;; system and other stuff. ;;; -(in-package 'hemlock) + +(in-package "HEMLOCK") ;;; We have "Keyboard Macro Transforms" that help in making a keyboard ;;; macro. What they do is turn the sequence of commands into equivalent @@ -63,7 +64,7 @@ (defun trash-character () "Throw away a character on *editor-input*." - (read-char *editor-input*)) + (get-key-event *editor-input*)) ;;; Save-Kbdmac-Input -- Internal ;;; @@ -93,11 +94,11 @@ (:invoke (let ((fun (command-function command)) (arg (prefix-argument)) - (lastc *last-character-typed*)) + (lastc *last-key-event-typed*)) (save-kbdmac-input (let ((*invoke-hook* *old-invoke-hook*)) (funcall fun arg)) - (kbdmac-emit `(set *last-character-typed* ,lastc)) + (kbdmac-emit `(set *last-key-event-typed* ,lastc)) (kbdmac-emit `(,fun ,arg))))))) ;;;; Self insert transform: @@ -106,15 +107,18 @@ ;;; insert it all at once. ;;; -(defvar *kbdmac-text* (make-array 100 :element-type 'string-char - :fill-pointer 0 - :adjustable t)) +(defvar *kbdmac-text* (make-array 100 :fill-pointer 0 :adjustable t)) (defun insert-string-at-point (string) (insert-string (buffer-point (current-buffer)) string)) (defun insert-character-at-point (character) (insert-character (buffer-point (current-buffer)) character)) +(defun key-vector-to-string (key-vector) + (let ((string (make-array (length key-vector) :element-type 'string-char))) + (dotimes (i (length key-vector) string) + (setf (aref string i) (key-event-char (aref key-vector i)))))) + (defun self-insert-kbdmac-transform (command key) (case key (:start @@ -123,12 +127,13 @@ (let ((p (or (prefix-argument) 1))) (funcall (command-function command) p) (dotimes (i p) - (vector-push-extend *last-character-typed* *kbdmac-text*)))) + (vector-push-extend *last-key-event-typed* *kbdmac-text*)))) (:finish - (if (> (length (the string *kbdmac-text*)) 1) + (if (> (length *kbdmac-text*) 1) (kbdmac-emit `(insert-string-at-point - ,(copy-seq (the string *kbdmac-text*)))) - (kbdmac-emit `(insert-character-at-point ,(char *kbdmac-text* 0))))))) + ,(key-vector-to-string *kbdmac-text*))) + (kbdmac-emit `(insert-character-at-point + ,(key-event-char (aref *kbdmac-text* 0)))))))) ;;; (define-kbdmac-transform "Self Insert" #'self-insert-kbdmac-transform) (define-kbdmac-transform "Lisp Insert )" #'self-insert-kbdmac-transform) @@ -344,7 +349,7 @@ (define-keyboard-macro)) (bind-key name key kind where) (message "~A bound to ~A." - (with-output-to-string (s) (sub-print-key key s)) + (with-output-to-string (s) (print-pretty-key key s)) name))))) ;;; GET-KEYBOARD-MACRO-KEY gets a key from the user and confirms clobbering it @@ -364,7 +369,7 @@ (if (prompt-for-y-or-n :prompt `("~A is bound to ~A. Rebind it? " ,(with-output-to-string (s) - (sub-print-key key s)) + (print-pretty-key key s)) ,(command-name cmd)) :default nil) (values key kind where) @@ -374,7 +379,7 @@ :prompt `("~A is a prefix for more than one command. ~ Clobber it? " ,(with-output-to-string (s) - (sub-print-key key s))) + (print-pretty-key key s))) :default nil) (values key kind where) nil))))))) @@ -440,7 +445,7 @@ (command-case (:prompt "Keyboard Macro Query: " :help "Type one of these characters to say what to do:" :change-window nil - :bind ch) + :bind key-event) (:exit "Exit this keyboard macro immediately." (throw 'exit-kbdmac nil)) @@ -460,5 +465,5 @@ (do-recursive-edit) (reprompt)) (t - (unread-char ch *editor-input*) + (unget-key-event key-event *editor-input*) (throw 'exit-kbdmac nil)))))) diff --git a/hemlock/lispmode.lisp b/hemlock/lispmode.lisp index 6e8a0d9d7..5fab8263b 100644 --- a/hemlock/lispmode.lisp +++ b/hemlock/lispmode.lisp @@ -1016,6 +1016,7 @@ according to the FORWARDP flag." of special arguments for the form. Examples: 2 for Do, 1 for Dolist. If a prefix argument is supplied, then delete the indentation information." "Do a defindent, man!" + (declare (ignore p)) (with-mark ((m (current-point))) (pre-command-parse-check m) (unless (backward-up-list m) (editor-error)) @@ -1165,6 +1166,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/macros.lisp b/hemlock/macros.lisp index f29561c55..d15f4527d 100644 --- a/hemlock/macros.lisp +++ b/hemlock/macros.lisp @@ -372,60 +372,73 @@ ;;;; COMMAND-CASE -;;; Command-Case -- Public +;;; COMMAND-CASE -- Public ;;; ;;; Grovel the awful thing and spit out the corresponding Cond. See Echo -;;; for the definition of command-case-help and logical char stuff. +;;; for the definition of COMMAND-CASE-HELP and logical char stuff. ;;; (eval-when (compile load eval) -(defun command-case-tag (tag char) +(defun command-case-tag (tag key-event char) (cond ((and (characterp tag) (standard-char-p tag)) - `(char= ,char ,(char-upcase tag))) + `(char= ,char ,tag)) ((and (symbolp tag) (keywordp tag)) - `(logical-char= ,char ,tag)) + `(logical-key-event-p ,key-event ,tag)) (t - (error "Tag in Command-Case is not a standard character or keyword:~S" + (error "Tag in COMMAND-CASE is not a standard character or keyword: ~S" tag)))) ); eval-when (compile load eval) ;;; -(defmacro command-case ((&key (change-window t) character +(defmacro command-case ((&key (change-window t) (prompt "Command character: ") (help "Choose one of the following characters:") (bind (gensym))) &body forms) + "This is analogous to the Common Lisp CASE macro. Commands such as \"Query + Replace\" use this to get a key-event, translate it to a character, and + then to dispatch on the character to the specified case. The syntax is + as follows: + (COMMAND-CASE ( {key value}* ) + {( {( {tag}* ) | tag} help {form}* )}* + ) + Each tag is either a character or a logical key-event. The user's typed + key-event is compared using either EXT:LOGICAL-KEY-EVENT-P or CHAR= of + EXT:KEY-EVENT-CHAR. + + The legal keys of the key/value pairs are :help, :prompt, :change-window, + and :bind. See the manual for details." (do* ((forms forms (cdr forms)) (form (car forms) (car forms)) (cases ()) (bname (gensym)) - (upper (gensym)) (again (gensym)) (n-prompt (gensym)) (n-change (gensym)) + (bind-char (gensym)) (docs ()) (t-case `(t (beep) (reprompt)))) ((atom forms) `(macrolet ((reprompt () `(progn - (setq ,',bind (prompt-for-character* - ,',n-prompt ,',n-change)) - (go ,',AGAIN)))) + (setf ,',bind + (prompt-for-key-event* ,',n-prompt ,',n-change)) + (setf ,',bind-char (ext:key-event-char ,',bind)) + (go ,',AGAIN)))) (block ,bname (let* ((,n-prompt ,prompt) (,n-change ,change-window) - (,bind ,(or character - `(prompt-for-character* ,n-prompt ,n-change)))) + (,bind (prompt-for-key-event* ,n-prompt ,n-change)) + (,bind-char (ext:key-event-char ,bind))) (tagbody ,AGAIN - (let ((,upper (char-upcase ,bind))) - (return-from - ,bname - (cond - ,@(nreverse cases) - ((logical-char= ,upper :abort) (editor-error)) - ((logical-char= ,upper :help) - (command-case-help ,help ',(nreverse docs)) - (reprompt)) - ,t-case)))))))) + (return-from + ,bname + (cond ,@(nreverse cases) + ((logical-key-event-p ,bind :abort) + (editor-error)) + ((logical-key-event-p ,bind :help) + (command-case-help ,help ',(nreverse docs)) + (reprompt)) + ,t-case))))))) (cond ((atom form) (error "Malformed Command-Case clause: ~S" form)) @@ -438,16 +451,19 @@ (let ((tag (car form)) (rest (cddr form))) (cond ((atom tag) - (push (cons (command-case-tag tag upper) rest) cases) + (push (cons (command-case-tag tag bind bind-char) rest) + cases) (setq tag (list tag))) (t (do ((tag tag (cdr tag)) - (res () (cons (command-case-tag (car tag) upper) res))) + (res () + (cons (command-case-tag (car tag) bind bind-char) + res))) ((null tag) (push `((or ,@res) . ,rest) cases))))) (push (cons tag (second form)) docs)))))) - + ;;;; Some random macros used everywhere. @@ -617,18 +633,18 @@ :format-string "Error in error handler; Hemlock broken."))))) (clear-echo-area) - (clear-input *editor-input*) + (clear-editor-input *editor-input*) (beep) (if internalp (write-string "Internal error: " *echo-area-stream*)) (princ condition *echo-area-stream*) (let* ((*editor-input* *real-editor-input*) - (ch (read-char *editor-input*))) - (if (char= ch #\?) + (key-event (get-key-event *editor-input*))) + (if (eq key-event #k"?") (loop (command-case (:prompt "Debug: " :help "Type one of the Hemlock debug command characters:") - ((#\D #\d) "Enter a break loop." + (#\d "Enter a break loop." (let ((device (device-hunk-device (window-hunk (current-window))))) (funcall (device-exit device) device) @@ -637,15 +653,15 @@ (continue "Return to Hemlock's debug loop.") (invoke-debugger condition)) (funcall (device-init device) device)))) - (#\B "Do a stack backtrace." + (#\b "Do a stack backtrace." (with-pop-up-display (*debug-io* :height 100) (debug:backtrace))) - (#\E "Show the error." + (#\e "Show the error." (with-pop-up-display (*standard-output*) (princ condition))) - ((#\Q :exit) "Throw back to Hemlock top-level." + ((#\q :exit) "Throw back to Hemlock top-level." (throw 'editor-top-level-catcher nil)) - ((#\r #\R) "Try to restart from this error." + (#\r "Try to restart from this error." (let ((cases (compute-restarts))) (declare (list cases)) (with-pop-up-display (s :height (1+ (length cases))) @@ -653,7 +669,7 @@ (invoke-restart-interactively (nth (prompt-for-integer :prompt "Restart number: ") cases)))))) - (unread-char ch *editor-input*)) + (unget-key-event key-event *editor-input*)) (throw 'editor-top-level-catcher nil)))) (defmacro handle-lisp-errors (&body body) diff --git a/hemlock/main.lisp b/hemlock/main.lisp index 3a84d8076..381293cee 100644 --- a/hemlock/main.lisp +++ b/hemlock/main.lisp @@ -17,8 +17,7 @@ (export '(*global-variable-names* *mode-names* *buffer-names* *character-attribute-names* *command-names* *buffer-list* - *window-list* *editor-input* *last-character-typed* - *character-history* after-editor-initializations)) + *window-list* *last-key-event-typed* after-editor-initializations)) (in-package "EXTENSIONS") diff --git a/hemlock/mh.lisp b/hemlock/mh.lisp index 66e331747..278f0e7e4 100644 --- a/hemlock/mh.lisp +++ b/hemlock/mh.lisp @@ -2558,14 +2558,16 @@ (let ((result ())) (declare (list result)) (loop - (let ((char (read-char *editor-input*))) - (ring-pop hi::*character-history*) - (cond ((char= char #\return) - (return (prog1 (coerce (nreverse result) 'simple-string) + (let ((key-event (get-key-event *editor-input*))) + (ring-pop hi::*key-event-history*) + (cond ((eq key-event #k"return") + (return (prog1 (coerce (nreverse result) + 'simple-string) (fill result nil)))) - ((or (char= char #\control-u) (char= char #\control-\u)) + ((or (eq key-event #k"control-u") + (eq key-event #k"control-U")) (setf result nil)) - (t (push char result))))))) + (t (push (ext:key-event-char key-event) result))))))) (setf (current-window) start-window))))) diff --git a/hemlock/morecoms.lisp b/hemlock/morecoms.lisp index 52b86e0b5..a07e07a23 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))) @@ -620,6 +618,7 @@ directory at point." "Insert a listing of the first non-blank line after each page mark at the beginning of the buffer." + (declare (ignore p)) (let ((point (current-point))) (unless p (push-buffer-mark (copy-mark point)) @@ -816,9 +815,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/overwrite.lisp b/hemlock/overwrite.lisp index 7d8d139fc..09a3605eb 100644 --- a/hemlock/overwrite.lisp +++ b/hemlock/overwrite.lisp @@ -33,7 +33,7 @@ "Replace the next character with the last character typed, but insert at end of line. With prefix argument, do it that many times." "Implements ``Self Overwrite'', calling this function is not meaningful." - (let ((char (text-character *last-character-typed*)) + (let ((char (ext:key-event-char *last-key-event-typed*)) (point (current-point))) (unless char (editor-error "Can't insert that character.")) (do ((n (or p 1) (1- n))) diff --git a/hemlock/register.lisp b/hemlock/register.lisp index 7180dafb3..89dda633c 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)) @@ -71,6 +71,7 @@ ;;; (defun flush-reg-references-to-deleted-buffer (buffer) (do-registers (name value) + (declare (ignore name)) (etypecase value (mark (when (eq (line-buffer (mark-line value)) buffer) (free-register name))) @@ -133,7 +134,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 9020d4a70..093542e3d 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*) @@ -193,7 +181,7 @@ ;;; (defvar *editor-windowed-input* nil) -#| + ;;; These are used for selecting X events. ;;; ;;; This says to send :key-press, :button-press, :button-release, :enter-notify, @@ -231,7 +219,9 @@ '("/usr/misc/.lisp/lib/fonts/" "/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 @@ -239,9 +229,9 @@ ;;; (defun init-raw-io (display) (setf *editor-windowed-input* nil) - (cond #+nil(display + (cond (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 +243,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*) @@ -263,7 +253,6 @@ (proclaim '(declaration values)) (proclaim '(special *default-font-family*)) -#| ;;; font-map-size should be defined in font.lisp, but SETUP-FONT-FAMILY would ;;; assume it to be special, issuing a nasty warning. ;;; @@ -323,7 +312,7 @@ (warn "Cannot open font -- ~S" font-name) nil))) -|# + ;;;; HEMLOCK-BEEP. @@ -339,31 +328,29 @@ (proclaim '(special *current-window*)) -#| ;;; BITMAP-BEEP is used in Hemlock for beeping when running under windowed ;;; input. ;;; -(defun bitmap-beep (device stream) +(defun bitmap-beep (display stream) (declare (ignore stream)) - (let ((display (bitmap-device-display device))) - (ecase (variable-value 'ed::bell-style) - (:border-flash - (flash-window-border *current-window*)) - (:feep - (xlib:bell display) - (xlib:display-force-output display)) - (:border-flash-and-feep - (xlib:bell display) - (xlib:display-force-output display) - (flash-window-border *current-window*)) - (:flash - (flash-window *current-window*)) - (:flash-and-feep - (xlib:bell display) - (xlib:display-force-output display) - (flash-window *current-window*)) - ((nil) ;Do nothing. - )))) + (ecase (variable-value 'ed::bell-style) + (:border-flash + (flash-window-border *current-window*)) + (:feep + (xlib:bell display) + (xlib:display-force-output display)) + (:border-flash-and-feep + (xlib:bell display) + (xlib:display-force-output display) + (flash-window-border *current-window*)) + (:flash + (flash-window *current-window*)) + (:flash-and-feep + (xlib:bell display) + (xlib:display-force-output display) + (flash-window *current-window*)) + ((nil) ;Do nothing. + ))) (proclaim '(special *foreground-background-xor*)) @@ -408,12 +395,12 @@ (xlib:draw-rectangle xwin gcontext 0 0 width height t) (xlib:display-force-output display)))) -|# + (defun hemlock-beep (stream) "Using the current window, calls the device's beep function on stream." (let ((device (device-hunk-device (window-hunk (current-window))))) - (funcall (device-beep device) device stream))) + (funcall (device-beep device) (bitmap-device-display device) stream))) @@ -476,7 +463,6 @@ (cond ((not *editor-windowed-input*) ,@body) (t -#+nil (ext:with-clx-event-handling (*editor-windowed-input* #'ext:object-set-event-handler) ,@body))))) @@ -491,7 +477,6 @@ (proclaim '(special *echo-area-window*)) -#| ;;; Maybe bury/unbury hemlock window when we go to and from Lisp. ;;; This should do something more sophisticated when we know what that is. ;;; @@ -499,14 +484,13 @@ (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)))) (xlib:display-force-output display)) -|# -(defvar *hemlock-window-mngt* nil;#'default-hemlock-window-mngt +(defvar *hemlock-window-mngt* #'default-hemlock-window-mngt "This function is called by HEMLOCK-WINDOW, passing its arguments. This may be nil.") @@ -519,425 +503,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 +;;;; Line Wrap Char. +(defvar *line-wrap-char* #\! + "The character to be displayed to indicate wrapped lines.") -;;;; 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)) +;;;; Current terminal character translation. +(defconstant termcap-file "/etc/termcap") - -;;;; 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)) - -|# - -;;; 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 +624,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 +635,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 +663,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))) @@ -1098,9 +674,8 @@ t) (t nil))) -#| (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) @@ -1112,53 +687,6 @@ t)) (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. @@ -1173,15 +701,17 @@ (typecase function (symbol (fun-defined-from-pathname (careful-symbol-function function))) (compiled-function - (let* ((source - (first - (c::compiled-debug-info-source - (%primitive header-ref - (%primitive header-ref function - system:%function-entry-constants-slot) - %function-constants-debug-info-slot))))) - (when (eq (c::debug-source-from source) :file) - (c::debug-source-name source)))) + (let* ((string (%primitive header-ref function + system:%function-defined-from-slot)) + (file (subseq string 0 (position #\space string :test #'char=)))) + (declare (simple-string file)) + (if (or (char= #\# (schar file 0)) + (string-equal file "lisp")) + nil + (if (string= file "/.." :end1 3) + (pathname (subseq file + (position #\/ file :test #'char= :start 4))) + (pathname file))))) (t nil))) @@ -1206,7 +736,6 @@ then this also outputs any 'function documentation for sym to *standard-output*." (describe fun) - #+nil (when (and (compiled-function-p fun) (not (eq (%primitive header-ref fun %function-name-slot) sym))) (let ((doc (documentation sym 'function))) @@ -1222,7 +751,7 @@ ;;;; X Stuff. -#| + ;;; Setting window cursors ... ;;; @@ -1324,7 +853,7 @@ (xlib:set-standard-properties (bitmap-hunk-xwindow (window-hunk window)) :icon-name (buffer-name new-buffer))) -|# + ;;;; Some hacks for supporting Hemlock under Mach. @@ -1357,7 +886,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 +900,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/scribe.lisp b/hemlock/scribe.lisp index fdca55675..c7f7bc0bb 100644 --- a/hemlock/scribe.lisp +++ b/hemlock/scribe.lisp @@ -8,7 +8,8 @@ ;;; Scott Fahlman (FAHLMAN@CMUC). ;;; ********************************************************************** ;;; -(in-package 'hemlock) + +(in-package "HEMLOCK") @@ -56,11 +57,11 @@ (defattribute "Scribe Syntax" "For Scribe Syntax, Possible types are: - :ESCAPE ; basically #\@. - :OPEN-PAREN ; Characters that open a Scribe paren: #\[, #\{, #\(, #\<. - :CLOSE-PAREN ; Characters that close a Scribe paren: #\], #\}, #\), #\>. - :SPACE ; Delimits end of a Scribe command. - :NEWLINE ; Delimits end of a Scribe command." + :ESCAPE ; basically #\@. + :OPEN-PAREN ; Characters that open a Scribe paren: #\[, #\{, #\(, #\<. + :CLOSE-PAREN ; Characters that close a Scribe paren: #\], #\}, #\), #\>. + :SPACE ; Delimits end of a Scribe command. + :NEWLINE ; Delimits end of a Scribe command." 'symbol nil) (setf (character-attribute :SCRIBE-SYNTAX #\)) :CLOSE-PAREN) @@ -142,7 +143,8 @@ "Inserts a the bracket it is bound to and then shows the matching bracket." "Inserts a the bracket it is bound to and then shows the matching bracket." (declare (ignore p)) - (scribe-insert-paren (current-point) *last-character-typed*)) + (scribe-insert-paren (current-point) + (ext:key-event-char *last-key-event-typed*))) (defhvar "Scribe Command Table" @@ -158,7 +160,7 @@ (defcommand "Add Scribe Directive" (p &optional (command-name nil command-name-p) - type key (mode "Scribe")) + type key-event mode) "Adds a new scribe function to put into \"Scribe Command Table\"." "Adds a new scribe function to put into \"Scribe Command Table\"." (declare (ignore p)) @@ -175,9 +177,16 @@ :help "Enter Command or Environment." :prompt "Command or Environment: ")) (declare (ignore ignore)) - (let ((key (or key - (prompt-for-character :prompt "Dispatch Character: ")))) - (setf (gethash key (variable-value 'scribe-command-table :mode mode)) + (let ((key-event (or key-event + (prompt-for-key-event :prompt + "Dispatch Character: ")))) + (setf (gethash key-event + (cond (mode + (variable-value 'scribe-command-table :mode mode)) + ((hemlock-bound-p 'scribe-command-table) + (value scribe-command-table)) + (t (editor-error + "Could not find \"Scribe Command Table\".")))) (cons type command-name)))))) (defcommand "Insert Scribe Directive" (p) @@ -190,14 +199,19 @@ Character\"." "Wrap some text with some stuff." (declare (ignore p)) - (command-case (:bind key :prompt "Dispatch Character: ") - (:help "help" - (directive-help) - (reprompt)) - (t (let ((table-entry (gethash key (value scribe-command-table)))) - (if (eq (car table-entry) :command) - (insert-scribe-directive (current-point) (cdr table-entry)) - (enclose-with-environment (current-point) (cdr table-entry))))))) + (loop + (let ((key-event (prompt-for-key-event :prompt "Dispatch Character: "))) + (if (logical-key-event-p key-event :help) + (directive-help) + (let ((table-entry (gethash key-event (value scribe-command-table)))) + (ecase (car table-entry) + (:command + (insert-scribe-directive (current-point) (cdr table-entry)) + (return)) + (:environment + (enclose-with-environment (current-point) (cdr table-entry)) + (return)) + ((nil) (editor-error "Unknown dispatch character.")))))))) @@ -211,9 +225,9 @@ (if (eql (car v) :command) (push (cons k (cdr v)) commands) (push (cons k (cdr v)) environments))) - (variable-value 'Scribe-Command-Table :mode "Scribe")) - (setq commands (sort commands #'string< :key #'cdr)) - (setq environments (sort environments #'string< :key #'cdr)) + (value scribe-command-table)) + (setf commands (sort commands #'string< :key #'cdr)) + (setf environments (sort environments #'string< :key #'cdr)) (with-pop-up-display (s :height (1+ (max (length commands) (length environments)))) (format s "~2TCommands~47TEnvironments~%") @@ -228,16 +242,60 @@ (env-name (rest environment))) (write-string " " s) (when cmd-char - (print-pretty-character cmd-char s) + (ext:print-pretty-key-event cmd-char s) (format s "~7T") (write-string (or cmd-name "<prompts for command name>") s)) (when env-char (format s "~47T") - (print-pretty-character env-char s) + (ext:print-pretty-key-event env-char s) (format s "~51T") (write-string (or env-name "<prompts for command name>") s)) (terpri s)))))) +;;; +;;; Inserting and extending :command directives. +;;; + +(defhvar "Insert Scribe Directive Function" + "\"Insert Scribe Directive\" calls this function when the directive type + is :command. The function takes four arguments: a mark pointing to the word + start, the formatting command string, the open-paren character to use, and a + mark pointing to the word end." + :value 'scribe-insert-scribe-directive-fun + :mode "Scribe") + +(defun scribe-insert-scribe-directive-fun (word-start command-string + open-paren-char word-end) + (insert-character word-start (value escape-character)) + (insert-string word-start command-string) + (insert-character word-start open-paren-char) + (insert-character word-end (value close-paren-character))) + +(defhvar "Extend Scribe Directive Function" + "\"Insert Scribe Directive\" calls this function when the directive type is + :command to extend the the commands effect. This function takes a string + and three marks: the first on pointing before the open-paren character for + the directive. The string is the command-string to selected by the user + which this function uses to determine if it is actually extending a command + or inserting a new one. The function must move the first mark before any + command text for the directive and the second mark to the end of any command + text. It moves the third mark to the previous word's start where the + command region should be. If this returns non-nil \"Insert Scribe + Directive\" moves the command region previous one word, and otherwise it + inserts the directive." + :value 'scribe-extend-scribe-directive-fun + :mode "Scribe") + +(defun scribe-extend-scribe-directive-fun (command-string + command-end command-start word-start) + (word-offset (move-mark command-start command-end) -1) + (when (string= (the simple-string (region-to-string + (region command-start command-end))) + command-string) + (mark-before command-start) + (mark-after command-end) + (word-offset (move-mark word-start command-start) -1))) + ;;; INSERT-SCRIBE-DIRECTIVE first looks for the current or previous word at ;;; mark. Word-p says if we found one. If mark is immediately before a word, ;;; we use that word instead of the previous. This is because if mark @@ -266,30 +324,34 @@ :trim t :prompt "Environment: " :help "Name of environment to enclose with.")))) (declare (simple-string command-string)) - (when word-p + (cond + (word-p (word-offset (move-mark word-end word-start) 1) - (when (test-char (next-character word-end) :scribe-syntax - :close-paren) - (with-mark ((command-start word-start) - (command-end word-end)) - (balance-paren (mark-after command-end)) - (word-offset (move-mark command-start command-end) -1) - (when (string= (the simple-string - (region-to-string (region command-start - command-end))) - command-string) - (mark-before command-start) - (mark-after command-end) - (setf open-paren-char - (opposing-bracket (next-character word-end))) - (delete-region (region command-start command-end)) - (delete-characters word-end) - (word-offset (move-mark word-start command-start) -1))))) - (insert-character word-start (value escape-character)) - (insert-string word-start command-string) - (insert-character word-start open-paren-char) - (insert-character word-end (value close-paren-character)) - (unless word-p (mark-before mark))))) + (if (test-char (next-character word-end) :scribe-syntax + :close-paren) + (with-mark ((command-start word-start :left-inserting) + (command-end word-end :left-inserting)) + ;; Move command-end from word-end to open-paren of command. + (balance-paren (mark-after command-end)) + (if (funcall (value extend-scribe-directive-function) + command-string command-end command-start word-start) + (let ((region (delete-and-save-region + (region command-start command-end)))) + (word-offset (move-mark word-start command-start) -1) + (ninsert-region word-start region)) + (funcall (value insert-scribe-directive-function) + word-start command-string open-paren-char + word-end))) + (funcall (value insert-scribe-directive-function) + word-start command-string open-paren-char word-end))) + (t + (funcall (value insert-scribe-directive-function) + word-start command-string open-paren-char word-end) + (mark-before mark)))))) + +;;; +;;; Inserting :environment directives. +;;; (defun enclose-with-environment (mark &optional environment) (if (region-active-p) @@ -324,8 +386,8 @@ (prompt-for-string :trim t :prompt "Environment: " :help "Name of environment to enclose with.")))) - (insert-environment top-mark "Begin" environment) - (insert-environment bottom-mark "End" environment))) + (insert-environment top-mark "begin" environment) + (insert-environment bottom-mark "end" environment))) (defun insert-environment (mark command environment) (let ((esc-char (value escape-character)) @@ -338,37 +400,37 @@ (insert-character mark close-paren))) -(Add-Scribe-Directive-Command nil nil :Environment #\Control-\l) -(Add-Scribe-Directive-Command nil nil :Command #\Control-\w) -(Add-Scribe-Directive-Command nil "Begin" :Command #\b) -(Add-Scribe-Directive-Command nil "End" :Command #\e) -(Add-Scribe-Directive-Command nil "Center" :Environment #\c) -(Add-Scribe-Directive-Command nil "Description" :Environment #\d) -(Add-Scribe-Directive-Command nil "Display" :Environment #\Control-\d) -(Add-Scribe-Directive-Command nil "Enumerate" :Environment #\n) -(Add-Scribe-Directive-Command nil "Example" :Environment #\x) -(Add-Scribe-Directive-Command nil "FileExample" :Environment #\y) -(Add-Scribe-Directive-Command nil "FlushLeft" :Environment #\l) -(Add-Scribe-Directive-Command nil "FlushRight" :Environment #\r) -(Add-Scribe-Directive-Command nil "Format" :Environment #\f) -(Add-Scribe-Directive-Command nil "Group" :Environment #\g) -(Add-Scribe-Directive-Command nil "Itemize" :Environment #\Control-\i) -(Add-Scribe-Directive-Command nil "Multiple" :Environment #\m) -(Add-Scribe-Directive-Command nil "ProgramExample" :Environment #\p) -(Add-Scribe-Directive-Command nil "Quotation" :Environment #\q) -(Add-Scribe-Directive-Command nil "Text" :Environment #\t) -(Add-Scribe-Directive-Command nil "i" :Command #\i) -(Add-Scribe-Directive-Command nil "b" :Command #\Control-\b) -(Add-Scribe-Directive-Command nil "-" :Command #\-) -(Add-Scribe-Directive-Command nil "+" :Command #\+) -(Add-Scribe-Directive-Command nil "u" :Command #\Control-\j) -(Add-Scribe-Directive-Command nil "p" :Command #\Control-\p) -(Add-Scribe-Directive-Command nil "r" :Command #\Control-\r) -(Add-Scribe-Directive-Command nil "t" :Command #\Control-\t) -(Add-Scribe-Directive-Command nil "g" :Command #\Control-\a) -(Add-Scribe-Directive-Command nil "un" :Command #\Control-\n) -(Add-Scribe-Directive-Command nil "ux" :Command #\Control-\x) -(Add-Scribe-Directive-Command nil "c" :Command #\Control-\k) +(add-scribe-directive-command nil nil :Environment #k"Control-l" "Scribe") +(add-scribe-directive-command nil nil :Command #k"Control-w" "Scribe") +(add-scribe-directive-command nil "Begin" :Command #k"b" "Scribe") +(add-scribe-directive-command nil "End" :Command #k"e" "Scribe") +(add-scribe-directive-command nil "Center" :Environment #k"c" "Scribe") +(add-scribe-directive-command nil "Description" :Environment #k"d" "Scribe") +(add-scribe-directive-command nil "Display" :Environment #k"Control-d" "Scribe") +(add-scribe-directive-command nil "Enumerate" :Environment #k"n" "Scribe") +(add-scribe-directive-command nil "Example" :Environment #k"x" "Scribe") +(add-scribe-directive-command nil "FileExample" :Environment #k"y" "Scribe") +(add-scribe-directive-command nil "FlushLeft" :Environment #k"l" "Scribe") +(add-scribe-directive-command nil "FlushRight" :Environment #k"r" "Scribe") +(add-scribe-directive-command nil "Format" :Environment #k"f" "Scribe") +(add-scribe-directive-command nil "Group" :Environment #k"g" "Scribe") +(add-scribe-directive-command nil "Itemize" :Environment #k"Control-i" "Scribe") +(add-scribe-directive-command nil "Multiple" :Environment #k"m" "Scribe") +(add-scribe-directive-command nil "ProgramExample" :Environment #k"p" "Scribe") +(add-scribe-directive-command nil "Quotation" :Environment #k"q" "Scribe") +(add-scribe-directive-command nil "Text" :Environment #k"t" "Scribe") +(add-scribe-directive-command nil "i" :Command #k"i" "Scribe") +(add-scribe-directive-command nil "b" :Command #k"Control-b" "Scribe") +(add-scribe-directive-command nil "-" :Command #k"\-" "Scribe") +(add-scribe-directive-command nil "+" :Command #k"+" "Scribe") +(add-scribe-directive-command nil "u" :Command #k"Control-j" "Scribe") +(add-scribe-directive-command nil "p" :Command #k"Control-p" "Scribe") +(add-scribe-directive-command nil "r" :Command #k"Control-r" "Scribe") +(add-scribe-directive-command nil "t" :Command #k"Control-t" "Scribe") +(add-scribe-directive-command nil "g" :Command #k"Control-a" "Scribe") +(add-scribe-directive-command nil "un" :Command #k"Control-n" "Scribe") +(add-scribe-directive-command nil "ux" :Command #k"Control-x" "Scribe") +(add-scribe-directive-command nil "c" :Command #k"Control-k" "Scribe") diff --git a/hemlock/searchcoms.lisp b/hemlock/searchcoms.lisp index 448323ec2..d2d23bcdf 100644 --- a/hemlock/searchcoms.lisp +++ b/hemlock/searchcoms.lisp @@ -174,54 +174,57 @@ ;;; (defun %i-search (string point trailer direction failure) (do* ((curr-point (copy-mark point :temporary)) - (curr-trailer (copy-mark trailer :temporary)) - (next-char (read-char *editor-input* nil) - (read-char *editor-input* nil))) + (curr-trailer (copy-mark trailer :temporary))) (nil) - (case (%i-search-char-eval next-char string point trailer direction failure) - (:cancel - (%i-search-echo-refresh string direction failure) - (unless (zerop (length string)) - (i-search-pattern string direction))) - (:return-cancel - (unless (zerop (length string)) (return :cancel)) - (beep)) - (:control-g - (when failure (return :control-g)) - (%i-search-echo-refresh string direction nil) - (unless (zerop (length string)) - (i-search-pattern string direction)))) - (move-mark point curr-point) - (move-mark trailer curr-trailer))) + (let ((next-key-event (get-key-event *editor-input* t))) + (case (%i-search-char-eval next-key-event string point trailer + direction failure) + (:cancel + (%i-search-echo-refresh string direction failure) + (unless (zerop (length string)) + (i-search-pattern string direction))) + (:return-cancel + (unless (zerop (length string)) (return :cancel)) + (beep)) + (:control-g + (when failure (return :control-g)) + (%i-search-echo-refresh string direction nil) + (unless (zerop (length string)) + (i-search-pattern string direction)))) + (move-mark point curr-point) + (move-mark trailer curr-trailer)))) ;;; %I-SEARCH-CHAR-EVAL evaluates the last character typed and takes ;;; necessary actions. ;;; -(defun %i-search-char-eval (char string point trailer direction failure) +(defun %i-search-char-eval (key-event string point trailer direction failure) (declare (simple-string string)) - (cond ((standard-char-p char) - (%i-search-printed-char char string point trailer direction failure)) - ((or (logical-char= char :forward-search) - (logical-char= char :backward-search)) - (%i-search-control-s-or-r char string point trailer direction failure)) - ((logical-char= char :cancel) :return-cancel) - ((logical-char= char :abort) + (cond ((let ((character (key-event-char key-event))) + (and character (standard-char-p character))) + (%i-search-printed-char key-event string point trailer + direction failure)) + ((or (logical-key-event-p key-event :forward-search) + (logical-key-event-p key-event :backward-search)) + (%i-search-control-s-or-r key-event string point trailer + direction failure)) + ((logical-key-event-p key-event :cancel) :return-cancel) + ((logical-key-event-p key-event :abort) (unless failure (clear-echo-area) (message "Search aborted.") (throw 'exit-i-search :control-g)) :control-g) - ((logical-char= char :quote) - (%i-search-printed-char (read-char *editor-input* nil) + ((logical-key-event-p key-event :quote) + (%i-search-printed-char (get-key-event *editor-input* t) string point trailer direction failure)) - ((and (zerop (length string)) (logical-char= char :exit)) + ((and (zerop (length string)) (logical-key-event-p key-event :exit)) (if (eq direction :forward) (forward-search-command nil) (reverse-search-command nil)) (throw 'exit-i-search nil)) (t - (unless (logical-char= char :exit) - (unread-char char *editor-input*)) + (unless (logical-key-event-p key-event :exit) + (unget-key-event key-event *editor-input*)) (unless (zerop (length string)) (setf *last-search-string* string)) (throw 'exit-i-search nil)))) @@ -231,9 +234,10 @@ ;;; has just been changed, there cannot be a failure before trying a new ;;; direction. ;;; -(defun %i-search-control-s-or-r (char string point trailer direction failure) +(defun %i-search-control-s-or-r (key-event string point trailer + direction failure) (let ((forward-direction-p (eq direction :forward)) - (forward-character-p (logical-char= char :forward-search))) + (forward-character-p (logical-key-event-p key-event :forward-search))) (cond ((zerop (length string)) (%i-search-empty-string point trailer direction forward-direction-p forward-character-p)) @@ -273,10 +277,10 @@ ;;; the end of the buffer or to include the next character at the beginning ;;; of the search. ;;; -(defun %i-search-printed-char (char string point trailer - direction failure) - (let ((tchar (text-character char))) - (unless tchar (editor-error "Not a text character -- ~S" char)) +(defun %i-search-printed-char (key-event string point trailer direction failure) + (let ((tchar (ext:key-event-char key-event))) + (unless tchar (editor-error "Not a text character -- ~S" (key-event-char + key-event))) (when (interactive) (insert-character (buffer-point *echo-area-buffer*) tchar) (force-output *echo-area-stream*)) @@ -475,7 +479,7 @@ (:prompt "Query replace: " :help "Type one of the following single-character commands:" - :change-window nil :bind ch) + :change-window nil :bind key-event) (:yes "Replace this occurrence." (replace-that-case replacement cap upper point length dumb)) @@ -494,7 +498,7 @@ (get-search-pattern target :forward)) (:exit "Exit immediately." (return nil)) - (t (unread-char ch *editor-input*) + (t (unget-key-event key-event *editor-input*) (return nil)))))) (length (the list *query-replace-undo-data*)))))) diff --git a/hemlock/shell.lisp b/hemlock/shell.lisp index 8f8cb6580..1ca0e0405 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. @@ -319,6 +385,7 @@ (defcommand "Stop Buffer Subprocess" (p) "Stop the subprocess currently executing in this shell." "Stop the subprocess currently executing in this shell." + (declare (ignore p)) (unless (hemlock-bound-p 'process :buffer (current-buffer)) (editor-error "Not in a process buffer.")) (deliver-signal-to-subprocess (if p :SIGSTOP :SIGTSTP) (value process))) diff --git a/hemlock/spellcoms.lisp b/hemlock/spellcoms.lisp index 2bf777757..8b8d35840 100644 --- a/hemlock/spellcoms.lisp +++ b/hemlock/spellcoms.lisp @@ -210,16 +210,17 @@ (delete-mark (ring-pop missed)) (return-from sub-correct-last-misspelled-word t)) (move-mark point (region-end region)) - (command-case (:prompt "Action: " :change-window nil + (command-case (:prompt "Action: " + :change-window nil :help "Type a single character command to do something to the misspelled word.") - (#\C "Try to find a correction for this word." + (#\c "Try to find a correction for this word." (unless (get-word-correction (region-start region) word folded) (reprompt))) - (#\I "Insert this word in the dictionary." + (#\i "Insert this word in the dictionary." (spell:spell-add-entry folded) (push folded (spell-info-insertions info)) (message "~A inserted in the dictionary." word)) - (#\R "Prompt for a word to replace this word with." + (#\r "Prompt for a word to replace this word with." (let ((s (prompt-for-string :prompt "Replace with: " :default word :help "Type a string to replace occurrences of this word with."))) @@ -231,10 +232,10 @@ (:recursive-edit "Go into a recursive edit and leave when it exits." (do-recursive-edit)) - ((:exit #\Q) "Exit and forget about this word.") + ((:exit #\q) "Exit and forget about this word.") ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) "Choose this numbered word as the correct spelling." - (let ((num (digit-char-p *last-character-typed*)) + (let ((num (digit-char-p (ext:key-event-char *last-key-event-typed*))) (close-words (spell:spell-collect-close-words folded))) (cond ((> num (length close-words)) (editor-error "Choice out of range.")) @@ -322,8 +323,9 @@ ((null words)) (format s "~36R=~A " i (car words))) (finish-output s) - (let* ((char (prompt-for-character :prompt "Correction choice: ")) - (num (digit-char-p char 36))) + (let* ((key-event (prompt-for-key-event + :prompt "Correction choice: ")) + (num (digit-char-p (ext:key-event-char key-event) 36))) (cond ((not num) (return-from get-word-correction nil)) ((> num (length close-words)) (editor-error "Choice out of range.")) @@ -522,40 +524,41 @@ (:prompt "Action: " :help "Type a single letter command, or help character for help." :change-window nil) - (#\I "Insert unknown word into dictionary for future lookup." - (spell:spell-add-entry word) - (push word (spell-info-insertions info)) - (format t "~S added to dictionary.~2%" word)) - (#\C "Correct the unknown word with possible correct spellings." - (unless close-words - (write-line "There are no possible corrections.") - (reprompt)) - (let ((num (if (= close-words-len 1) 0 - (digit-char-p (prompt-for-character - :prompt "Correction choice: ") - 36)))) - (unless num (reprompt)) - (when (> num close-words-len) - (beep) - (write-line "Response out of range.") - (reprompt)) - (let ((choice (nth num close-words))) - (setf (gethash word *spelling-corrections*) choice) - (spell-replace-word mark unfolded-word choice))) - (terpri)) - (#\A "Accept the word as correct (that is, ignore it)." - (character-offset mark wordlen)) - (#\R "Replace the unknown word with a supplied replacement." - (let ((s (prompt-for-string - :prompt "Replacement Word: " - :default unfolded-word - :help "String to replace the unknown word with."))) - (setf (gethash word *spelling-corrections*) s) - (spell-replace-word mark unfolded-word s)) - (terpri)) - (:recursive-edit - "Go into a recursive edit and resume correction where the point is left." - (do-recursive-edit))))) + (#\i "Insert unknown word into dictionary for future lookup." + (spell:spell-add-entry word) + (push word (spell-info-insertions info)) + (format t "~S added to dictionary.~2%" word)) + (#\c "Correct the unknown word with possible correct spellings." + (unless close-words + (write-line "There are no possible corrections.") + (reprompt)) + (let ((num (if (= close-words-len 1) 0 + (digit-char-p (ext:key-event-char + (prompt-for-key-event + :prompt "Correction choice: ")) + 36)))) + (unless num (reprompt)) + (when (> num close-words-len) + (beep) + (write-line "Response out of range.") + (reprompt)) + (let ((choice (nth num close-words))) + (setf (gethash word *spelling-corrections*) choice) + (spell-replace-word mark unfolded-word choice))) + (terpri)) + (#\a "Accept the word as correct (that is, ignore it)." + (character-offset mark wordlen)) + (#\r "Replace the unknown word with a supplied replacement." + (let ((s (prompt-for-string + :prompt "Replacement Word: " + :default unfolded-word + :help "String to replace the unknown word with."))) + (setf (gethash word *spelling-corrections*) s) + (spell-replace-word mark unfolded-word s)) + (terpri)) + (:recursive-edit + "Go into a recursive edit and resume correction where the point is left." + (do-recursive-edit))))) ;;; Spell-Replace-Word -- Internal ;;; diff --git a/hemlock/srccom.lisp b/hemlock/srccom.lisp index 246b68ae1..87a14ea4e 100644 --- a/hemlock/srccom.lisp +++ b/hemlock/srccom.lisp @@ -153,12 +153,12 @@ (region temp-b (line-start temp-a (line-next (mark-line temp-b)))))) - (#\B "Insert both versions with **** MERGE LOSSAGE **** around them." + (#\b "Insert both versions with **** MERGE LOSSAGE **** around them." (insert-string temp-a " **** MERGE LOSSAGE ****") (insert-string dest-point " **** END OF MERGE LOSSAGE ****")) - (#\A "Align window at start of difference display." + (#\a "Align window at start of difference display." (line-start (move-mark (window-display-start diff --git a/hemlock/streams.lisp b/hemlock/streams.lisp index c719b9aad..0cfea3093 100644 --- a/hemlock/streams.lisp +++ b/hemlock/streams.lisp @@ -207,9 +207,7 @@ (length (length chars)) (last (region-end (hemlock-region-stream-region stream))) (last-line (mark-line last)) - (buffer (lisp::stream-in-buffer stream)) - (start 0) - (len 0)) + (buffer (lisp::stream-in-buffer stream)) start len) (declare (fixnum length charpos last-charpos start len) (simple-string chars)) (cond @@ -248,6 +246,7 @@ (schar buffer start))) (defun region-misc (stream operation &optional arg1 arg2) + (declare (ignore arg1 arg2)) (case operation (:listen (mark< (hemlock-region-stream-mark stream) (region-end (hemlock-region-stream-region stream)))) @@ -262,52 +261,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 550ed0ca7..fa4c7f313 100644 --- a/hemlock/struct.lisp +++ b/hemlock/struct.lisp @@ -57,7 +57,8 @@ font) (defmacro fast-font-mark-p (s) - `(typep ,s 'font-mark)) + `(eq (svref ,s 0) 'font-mark)) + ;;;; Regions, buffers, modeline fields. @@ -589,7 +590,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/termcap.lisp b/hemlock/termcap.lisp index 8d57c2f76..f0270cc27 100644 --- a/hemlock/termcap.lisp +++ b/hemlock/termcap.lisp @@ -374,39 +374,37 @@ (setf (cdr ele) nil))) (return termcap))) -;;; GET-TERMCAP-STRING-CHAR parses/lexes a character out of the termcap -;;; file, converting it first into the appropriate Common Lisp character. -;;; The Common Lisp character is then converted by CL-TERMCAP-CHAR into -;;; another Common Lisp character but one that will eventually have the -;;; right bits on (or be the necessary fixnum) for sending to terminals. -;;; If this function needs to look ahead to determine any characters, it -;;; unreads the character. -;;; +;;; GET-TERMCAP-STRING-CHAR -- Internal. +;;; +;;; This parses/lexes an ASCII character out of the termcap file and converts +;;; it into the appropriate Common Lisp character. This is a Common Lisp +;;; character with the same CHAR-CODE code as the ASCII code, so writing the +;;; character to the tty will have the desired effect. If this function needs +;;; to look ahead to determine any characters, it unreads the character. +;;; (defun get-termcap-string-char (stream char) - (cl-termcap-char - (case char - (#\\ - (case (getchar) - (#\E #\alt) - (#\n #\newline) - (#\r #\return) - (#\t #\tab) - (#\b #\backspace) - (#\f #\formfeed) - (#\^ #\^) - (#\\ #\\) - ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) - (let ((result 0) - (digit (digit-char-p char))) - (loop (setf result (+ digit (* 8 result))) - (unless (setf digit (digit-char-p (getchar))) - (ungetchar char) - (return (translate-tty-char (ldb (byte 7 0) result))))))) - (t (error "Bad termcap format -- unknown backslash character.")))) - (#\^ - (set-char-bit (char-upcase (getchar)) :control t)) - (t char)))) - + (case char + (#\\ + (case (getchar) + (#\E (code-char 27)) + (#\n (code-char 10)) + (#\r (code-char 13)) + (#\t (code-char 9)) + (#\b (code-char 8)) + (#\f (code-char 12)) + (#\^ #\^) + (#\\ #\\) + ((#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9) + (let ((result 0) + (digit (digit-char-p char))) + (loop (setf result (+ digit (* 8 result))) + (unless (setf digit (digit-char-p (getchar))) + (ungetchar char) + (return (code-char (ldb (byte 7 0) result))))))) + (t (error "Bad termcap format -- unknown backslash character.")))) + (#\^ + (code-char (- (char-code (char-upcase (getchar))) 64))) + (t char))) ;;;; Initialization file string. diff --git a/hemlock/ts-buf.lisp b/hemlock/ts-buf.lisp index e20b44ee2..7157c1625 100644 --- a/hemlock/ts-buf.lisp +++ b/hemlock/ts-buf.lisp @@ -246,13 +246,23 @@ :value "Cause the slave to throw to the top level? " :mode "Typescript") +;;; TYPESCRIPT-DATA-OR-LOSE -- internal +;;; +;;; Return the typescript-data for the current buffer, or die trying. +;;; +(defun typescript-data-or-lose () + (if (hemlock-bound-p 'typescript-data) + (let ((ts (value typescript-data))) + (if ts + ts + (editor-error "Can't find the typescript data?"))) + (editor-error "Not in a typescript buffer."))) + (defcommand "Confirm Typescript Input" (p) "Send the current input to the slave typescript." "Send the current input to the slave typescript." (declare (ignore p)) - (let ((ts (value typescript-data))) - (unless ts - (editor-error "This buffer has no typescript data!")) + (let ((ts (typescript-data-or-lose))) (let ((input (get-interactive-input))) (when input (let ((string (region-to-string input))) @@ -284,7 +294,7 @@ (send-oob-to-slave "T")) (defun send-oob-to-slave (string) - (let* ((ts (value typescript-data)) + (let* ((ts (typescript-data-or-lose)) (wire (ts-data-wire ts)) (socket (wire:wire-fd wire))) (unless socket diff --git a/hemlock/tty-display.lisp b/hemlock/tty-display.lisp index 1473c85d5..f555e2d16 100644 --- a/hemlock/tty-display.lisp +++ b/hemlock/tty-display.lisp @@ -193,6 +193,7 @@ (let* ((dl first-changed) flags ;(dis-line-flags (car dl))) flags bound for NEXT-DIS-LINE. prev) + (declare (ignore flags)) ;; ;; Skip old, unchanged, unmoved lines. ;; (loop @@ -218,7 +219,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))) @@ -226,7 +228,7 @@ (si-line-length (si-line-length screen-image-line)) (findex (string/= dl-chars si-line-chars :end1 dl-len :end2 si-line-length))) - (declare (type (or fixnum null) findex) (simple-string si-line-chars)) + (declare (fixnum findex) (simple-string si-line-chars)) ;; ;; When the dis-line and screen chars are not string=. (when findex @@ -711,7 +713,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))) @@ -719,7 +722,7 @@ (si-line-length (si-line-length screen-image-line)) (findex (string/= dl-chars si-line-chars :end1 dl-len :end2 si-line-length))) - (declare (type (or fixnum null) findex) (simple-string si-line-chars)) + (declare (fixnum findex) (simple-string si-line-chars)) ;; ;; When the dis-line and screen chars are not string=. (when findex @@ -928,7 +931,7 @@ (device (device-hunk-device hunk))) (if upos (let ((previous start) - (after-pos 0)) + after-pos) (declare (fixnum previous after-pos)) (loop (device-write-string string previous upos) (setf after-pos (do ((i (1+ upos) (1+ i))) @@ -1027,7 +1030,7 @@ (char-end-string (tty-device-insert-char-end-string device)) (ces-len (if char-end-string (length char-end-string))) (end-string (tty-device-insert-end-string device))) - (declare (type (or simple-string null) char-init-string char-end-string)) + (declare (simple-string char-init-string char-end-string)) (when init-string (device-write-string init-string)) (if char-init-string (do ((i start (1+ i))) @@ -1058,7 +1061,7 @@ (when end-string (incf cost (length (the simple-string end-string)))) (< cost insert-char-num))) -(defun delete-char (hunk x y &optional (n 1)) +(defun delete-char (hunk x y &optional n) (declare (fixnum x y n)) (update-cursor hunk x y) (let* ((device (device-hunk-device hunk)) @@ -1071,14 +1074,13 @@ (when end-string (device-write-string end-string)))) (defun worth-using-delete-mode (device delete-char-num clear-char-num) - (declare (fixnum delete-char-num clear-char-num)) + (declare (fixnum num)) (let ((init-string (tty-device-delete-init-string device)) (end-string (tty-device-delete-end-string device)) (delete-char-string (tty-device-delete-char-string device)) (clear-to-eol-string (tty-device-clear-to-eol-string device)) (cost 0)) - (declare (type (or simple-string null) init-string end-string - delete-char-string) + (declare (simple-string init-string end-string delete-char-string) (fixnum cost)) (when init-string (incf cost (the fixnum (length init-string)))) (when end-string (incf cost (the fixnum (length end-string)))) diff --git a/tools/hemcom.lisp b/tools/hemcom.lisp index 2093f8fb8..bbf59b8ea 100644 --- a/tools/hemcom.lisp +++ b/tools/hemcom.lisp @@ -2,8 +2,6 @@ ;;; This file compiles all of Hemlock. ;;; -(c::%proclaim '(optimize (debug-info 2))) -#| (when (ext:get-command-line-switch "slave") (error "Cannot compile Hemlock in a slave due to its clobbering needed typescript routines by renaming the package.")) @@ -12,12 +10,12 @@ ;;; Blast the old packages in case they are around. We do this solely to ;;; prove Hemlock can compile cleanly without its having to exist already. ;;; -(unless (find-package "OLD-ED") - (when (find-package "ED") - (rename-package (find-package "ED") "OLD-ED")) - (when (find-package "HI") - (rename-package (find-package "HI") "OLD-HI"))) -|# +(when (find-package "ED") + (rename-package (find-package "ED") "OLD-ED")) +;;; +(when (find-package "HI") + (rename-package (find-package "HI") "OLD-HI")) + ;;; Stuff to set up the packages Hemlock uses. ;;; @@ -33,126 +31,137 @@ (export '(%sp-byte-blt %sp-find-character %sp-find-character-with-attribute %sp-reverse-find-character-with-attribute)) -(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") +(in-package "HEMLOCK-INTERNALS") (pushnew :command-bits *features*) (pushnew :buffered-lines *features*) +(defparameter the-log-file "hem:lossage.log") -(with-compiler-log-file ("hem:lossage.log") +(when (probe-file the-log-file) + (delete-file the-log-file)) -(comf "code:globals" :always-once t) -(comf "code:struct" :always-once t) -(comf "hem:struct" :always-once t) -(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:macros" :always-once t) -(comf "hem:line" :always-once t) -(comf "hem:ring") -(comf "hem:table") -(comf "hem:htext1") -(comf "hem:htext2") -(comf "hem:htext3") -(comf "hem:htext4") -(comf "hem:search1") -(comf "hem:search2") -(comf "hem:linimage") -(comf "hem:cursor") -(comf "hem:syntax") -(comf "hem:winimage") -;(comf "hem:hunk-draw") -;(comf "hem:bit-stream") -(comf "hem:termcap") -(comf "hem:display") -;(comf "hem:bit-display") -(comf "hem:tty-disp-rt") -(comf "hem:tty-display") -;(comf "hem:tty-stream") -(comf "hem:pop-up-stream") -(comf "hem:screen") -;(comf "hem:bit-screen") -(comf "hem:tty-screen") -(comf "hem:window") -(comf "hem:font") -(comf "hem:interp") -(comf "hem:vars") -(comf "hem:buffer") -(comf "hem:files") -(comf "hem:streams") -(comf "hem:echo") -(comf "hem:main") -(comf "hem:echocoms") -(comf "hem:defsyn") -(comf "hem:command") -(comf "hem:morecoms") -(comf "hem:undo") -(comf "hem:killcoms") -(comf "hem:searchcoms") -(comf "hem:filecoms") -(comf "hem:indent") -(comf "hem:lispmode") -(comf "hem:comments") -(comf "hem:fill") -(comf "hem:text") -(comf "hem:doccoms") -(comf "hem:srccom") -(comf "hem:group") -(comf "hem:spell-rt") -(comf "hem:spell-corr") -(comf "hem:spell-aug") -(comf "hem:spell-build") -(comf "hem:spellcoms") -(comf "hem:abbrev") -(comf "hem:overwrite") -(comf "hem:gosmacs") -(comf "hem:ts-buf") -(comf "hem:ts-stream") -(comf "hem:eval-server") -(comf "hem:lispbuf") -(comf "hem:lispeval") -(comf "hem:kbdmac") -(comf "hem:icom") -(comf "hem:hi-integrity") -(comf "hem:ed-integrity") -(comf "hem:scribe") -(comf "hem:pascal") -(comf "hem:edit-defs") -(comf "hem:auto-save") -(comf "hem:register") -(comf "hem:xcoms") -(comf "hem:unixcoms") -(comf "hem:mh") -(comf "hem:highlight") -(comf "hem:dired") -(comf "hem:diredcoms") -(comf "hem:bufed") -(comf "hem:lisp-lib") -(comf "hem:completion") -(comf "hem:shell") -(comf "hem:bindings") -(comf "hem:hacks") +(defun cf (file &key load) + (write-line file) + (finish-output nil) + (let ((*error-output* (open the-log-file + :direction :output + :if-exists :append + :if-does-not-exist :create))) + (unwind-protect + (progn + (compile-file file :error-file nil) + (terpri *error-output*) (terpri *error-output*) + (when load + (let ((fasl (make-pathname :device (pathname-device file) + :directory (pathname-directory file) + :name (pathname-name file) + :type "fasl"))) + (write-string "Loading ") + (write-line (namestring fasl)) + (load fasl)))) + (close *error-output*)))) + +(cf "hem:struct.lisp") +(cf "hem:struct-ed.lisp") +(cf "hem:rompsite.lisp") +(cf "hem:charmacs.lisp") + +(cf "hem:key-event.lisp" :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) +(cf "hem:keysym-defs.lisp" :load t) -); With-Compiler-Log-File +(cf "hem:input.lisp") +(cf "hem:macros.lisp") +(cf "hem:line.lisp") +(cf "hem:ring.lisp") +(cf "hem:table.lisp") +(cf "hem:htext1.lisp") +(cf "hem:htext2.lisp") +(cf "hem:htext3.lisp") +(cf "hem:htext4.lisp") +(cf "hem:search1.lisp") +(cf "hem:search2.lisp") +(cf "hem:linimage.lisp") +(cf "hem:cursor.lisp") +(cf "hem:syntax.lisp") +(cf "hem:winimage.lisp") +(cf "hem:hunk-draw.lisp") +;(cf "hem:bit-stream.lisp") +(cf "hem:termcap.lisp") +(cf "hem:display.lisp") +(cf "hem:bit-display.lisp") +(cf "hem:tty-disp-rt.lisp") +(cf "hem:tty-display.lisp") +;(cf "hem:tty-stream.lisp") +(cf "hem:pop-up-stream.lisp") +(cf "hem:screen.lisp") +(cf "hem:bit-screen.lisp") +(cf "hem:tty-screen.lisp") +(cf "hem:window.lisp") +(cf "hem:font.lisp") +(cf "hem:interp.lisp") +(cf "hem:vars.lisp") +(cf "hem:buffer.lisp") +(cf "hem:files.lisp") +(cf "hem:streams.lisp") +(cf "hem:echo.lisp") +(cf "hem:main.lisp") +(cf "hem:echocoms.lisp") +(cf "hem:defsyn.lisp") +(cf "hem:command.lisp") +(cf "hem:morecoms.lisp") +(cf "hem:undo.lisp") +(cf "hem:killcoms.lisp") +(cf "hem:searchcoms.lisp") +(cf "hem:filecoms.lisp") +(cf "hem:indent.lisp") +(cf "hem:lispmode.lisp") +(cf "hem:comments.lisp") +(cf "hem:fill.lisp") +(cf "hem:text.lisp") +(cf "hem:doccoms.lisp") +(cf "hem:srccom.lisp") +(cf "hem:group.lisp") +(cf "hem:spell-rt.lisp") +(cf "hem:spell-corr.lisp") +(cf "hem:spell-aug.lisp") +(cf "hem:spell-build.lisp") +(cf "hem:spellcoms.lisp") +(cf "hem:abbrev.lisp") +(cf "hem:overwrite.lisp") +(cf "hem:gosmacs.lisp") +(cf "hem:ts-buf.lisp") +(cf "hem:ts-stream.lisp") +(cf "hem:eval-server.lisp") +(cf "hem:lispbuf.lisp") +(cf "hem:lispeval.lisp") +(cf "hem:kbdmac.lisp") +(cf "hem:icom.lisp") +(cf "hem:hi-integrity.lisp") +(cf "hem:ed-integrity.lisp") +(cf "hem:scribe.lisp") +(cf "hem:pascal.lisp") +(cf "hem:edit-defs.lisp") +(cf "hem:auto-save.lisp") +(cf "hem:register.lisp") +(cf "hem:xcoms.lisp") +(cf "hem:unixcoms.lisp") +(cf "hem:mh.lisp") +(cf "hem:highlight.lisp") +(cf "hem:dired.lisp") +(cf "hem:diredcoms.lisp") +(cf "hem:bufed.lisp") +(cf "hem:lisp-lib.lisp") +(cf "hem:completion.lisp") +(cf "hem:shell.lisp") +(cf "hem:bindings.lisp") -- GitLab