From 61ee3de2e546f55d7712214881b3ec0278bbf03e Mon Sep 17 00:00:00 2001 From: ram <ram> Date: Fri, 11 Feb 1994 21:54:44 +0000 Subject: [PATCH] Copy new_compiler branch to trunk. --- hemlock/abbrev.lisp | 2 +- hemlock/bindings.lisp | 153 +++++++-- hemlock/bit-stream.lisp | 2 +- hemlock/charmacs.lisp | 74 ++--- hemlock/cursor.lisp | 2 +- hemlock/dired.lisp | 2 +- hemlock/diredcoms.lisp | 34 +- hemlock/echocoms.lisp | 41 ++- hemlock/eval-server.lisp | 2 +- hemlock/filecoms.lisp | 60 ++-- hemlock/files.lisp | 207 ++++++------ hemlock/fill.lisp | 18 +- hemlock/group.lisp | 2 +- hemlock/htext2.lisp | 2 +- hemlock/htext3.lisp | 2 +- hemlock/input.lisp | 64 ++-- hemlock/kbdmac.lisp | 15 +- hemlock/key-event.lisp | 2 +- hemlock/killcoms.lisp | 2 +- hemlock/line.lisp | 2 +- hemlock/linimage.lisp | 2 +- hemlock/lispbuf.lisp | 2 +- hemlock/lispeval.lisp | 2 +- hemlock/lispmode.lisp | 606 +++++++++++++++++++++++++--------- hemlock/mh.lisp | 323 +++++++++---------- hemlock/morecoms.lisp | 20 +- hemlock/pop-up-stream.lisp | 2 +- hemlock/register.lisp | 16 +- hemlock/ring.lisp | 2 +- hemlock/rompsite.lisp | 642 +++++++++++++++++++++---------------- hemlock/screen.lisp | 36 ++- hemlock/search1.lisp | 2 +- hemlock/shell.lisp | 193 ++++++++++- hemlock/spell-aug.lisp | 2 +- hemlock/spell-build.lisp | 2 +- hemlock/spell-corr.lisp | 2 +- hemlock/spell-rt.lisp | 2 +- hemlock/spellcoms.lisp | 21 +- hemlock/streams.lisp | 129 ++------ hemlock/struct.lisp | 47 +-- hemlock/syntax.lisp | 2 +- hemlock/table.lisp | 2 +- hemlock/text.lisp | 2 +- hemlock/ts-stream.lisp | 2 +- hemlock/tty-disp-rt.lisp | 2 +- hemlock/tty-display.lisp | 459 ++++++++++++++++++-------- hemlock/tty-stream.lisp | 2 +- 47 files changed, 2039 insertions(+), 1173 deletions(-) diff --git a/hemlock/abbrev.lisp b/hemlock/abbrev.lisp index 9ce843d0f..6cfc0e790 100644 --- a/hemlock/abbrev.lisp +++ b/hemlock/abbrev.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/abbrev.lisp,v 1.1.1.4 1991/11/09 03:05:25 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/abbrev.lisp,v 1.2 1994/02/11 21:54:44 ram Exp $") ;;; ;;; ********************************************************************** ;;; diff --git a/hemlock/bindings.lisp b/hemlock/bindings.lisp index 0a0734ac2..a323af9ec 100644 --- a/hemlock/bindings.lisp +++ b/hemlock/bindings.lisp @@ -1,11 +1,14 @@ ;;; -*- Log: hemlock.log; Package: Hemlock -*- ;;; ;;; ********************************************************************** -;;; This code was written as part of the Spice Lisp project at -;;; Carnegie-Mellon University, and has been placed in the public domain. -;;; Spice Lisp is currently incomplete and under active development. -;;; If you want to use this code or any part of Spice Lisp, please contact -;;; Scott Fahlman (FAHLMAN@CMUC). +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/bindings.lisp,v 1.4 1994/02/11 21:52:48 ram Exp $") +;;; ;;; ********************************************************************** ;;; ;;; Some bindings: @@ -156,8 +159,8 @@ (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 "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") @@ -331,6 +334,7 @@ (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 "Typescript Slave Status" #k"hyper-s" :mode "Typescript") (bind-key "Select Slave" #k"control-meta-\c") (bind-key "Select Background" #k"control-meta-C") @@ -345,6 +349,7 @@ ;;;; Lisp (some). (bind-key "Indent Form" #k"control-meta-q") +(bind-key "Fill Lisp Comment Paragraph" #k"meta-q" :mode "Lisp") (bind-key "Defindent" #k"control-meta-#") (bind-key "Beginning of Defun" #k"control-meta-[") (bind-key "End of Defun" #k"control-meta-]") @@ -382,6 +387,25 @@ (bind-key "Goto Definition" #k"control-meta-F") +(bind-key "Debug Up" #k"control-meta-hyper-u") +(bind-key "Debug Down" #k"control-meta-hyper-d") +(bind-key "Debug Top" #k"control-meta-hyper-t") +(bind-key "Debug Bottom" #k"control-meta-hyper-b") +(bind-key "Debug Frame" #k"control-meta-hyper-f") +(bind-key "Debug Quit" #k"control-meta-hyper-q") +(bind-key "Debug Go" #k"control-meta-hyper-g") +(bind-key "Debug Abort" #k"control-meta-hyper-a") +(bind-key "Debug Restart" #k"control-meta-hyper-r") +(bind-key "Debug Help" #k"control-meta-hyper-h") +(bind-key "Debug Error" #k"control-meta-hyper-e") +(bind-key "Debug Backtrace" #k"control-meta-hyper-B") +(bind-key "Debug Print" #k"control-meta-hyper-p") +(bind-key "Debug Verbose Print" #k"control-meta-hyper-P") +(bind-key "Debug List Locals" #k"control-meta-hyper-l") +(bind-key "Debug Source" #k"control-meta-hyper-s") +(bind-key "Debug Edit Source" #k"control-meta-hyper-S") +(bind-key "Debug Flush Errors" #k"control-meta-hyper-F") + ;;;; More Miscellaneous bindings. @@ -391,7 +415,7 @@ (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 "Transpose Regions" #k"control-x t") (bind-key "Uppercase Region" #k"control-x control-u") (bind-key "Lowercase Region" #k"control-x control-l") @@ -435,7 +459,7 @@ (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 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") @@ -539,13 +563,16 @@ ;;;; Mailer commands. +;;; Clear everything user might hit to avoid getting the internal error +;;; message about modifying read-only buffers. +;;; (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" #k"control-x i") (bind-key "Send Message" #k"control-x m") (bind-key "Message Headers" #k"control-x r") @@ -556,7 +583,6 @@ ;;; The bindings in these two blocks should be the same, one for "Message" mode ;;; and one for "Headers" mode. ;;; - (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") @@ -572,7 +598,7 @@ (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") @@ -591,7 +617,7 @@ ;;; Headers mode. - +;;; (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") @@ -602,7 +628,7 @@ ;;; Message mode. - +;;; (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") @@ -616,7 +642,7 @@ ;;; Draft mode. - +;;; (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") @@ -627,11 +653,102 @@ (bind-key "Draft Help" #k"hyper-?" :mode "Draft") + +;;;; Netnews. + +;;; Clear everything user might hit to avoid getting the internal error +;;; message about modifying read-only buffers. +;;; +(do-alpha-key-events (key-event :both) + (bind-key "Illegal" key-event :mode "News-Headers") + (bind-key "Illegal" key-event :mode "News-Message")) + + +;;; Global Netnews bindings +;;; +(bind-key "Netnews Post Message" #k"C-x P") + + +;;; Both News-Headers and News-Message modes. +;;; +;;; The bindings in these two blocks should be the same, one for "News-Message" +;;; mode and one for "News-Headers" mode. +;;; +(bind-key "List All Groups" #k"l" :mode "News-Headers") +(bind-key "Netnews Append to File" #k"a" :mode "News-Headers") +(bind-key "Netnews Forward Message" #k"f" :mode "News-Headers") +(bind-key "Netnews Go to Next Group" #k"g" :mode "News-Headers") +(bind-key "Netnews Next Article" #k"n" :mode "News-Headers") +(bind-key "Netnews Previous Article" #k"p" :mode "News-Headers") +(bind-key "Netnews Quit Starting Here" #k"." :mode "News-Headers") +(bind-key "Netnews Group Punt Messages" #k"G" :mode "News-Headers") +(bind-key "Netnews Show Whole Header" #k"w" :mode "News-Headers") +(bind-key "Netnews Reply to Sender in Other Window" #k"r" :mode "News-Headers") +(bind-key "Netnews Reply to Group in Other Window" #k"R" :mode "News-Headers") +;;; +(bind-key "List All Groups" #k"l" :mode "News-Message") +(bind-key "Netnews Append to File" #k"a" :mode "News-Message") +(bind-key "Netnews Forward Message" #k"f" :mode "News-Message") +(bind-key "Netnews Go to Next Group" #k"g" :mode "News-Message") +(bind-key "Netnews Next Article" #k"n" :mode "News-Message") +(bind-key "Netnews Previous Article" #k"p" :mode "News-Message") +(bind-key "Netnews Quit Starting Here" #k"." :mode "News-Message") +(bind-key "Netnews Group Punt Messages" #k"G" :mode "News-Message") +(bind-key "Netnews Show Whole Header" #k"w" :mode "News-Message") +(bind-key "Netnews Reply to Sender in Other Window" #k"r" :mode "News-Message") +(bind-key "Netnews Reply to Group in Other Window" #k"R" :mode "News-Message") + + +;;; News-Headers. +;;; +(bind-key "Netnews Exit" #k"q" :mode "News-Headers") +(bind-key "Netnews Headers File Message" #k"o" :mode "News-Headers") +(bind-key "Netnews Headers Scroll Window Down" #k"c-v" :mode "News-Headers") +(bind-key "Netnews Headers Scroll Window Up" #k"m-v" :mode "News-Headers") +(bind-key "Netnews Next Line" #k"C-n" :mode "News-Headers") +(bind-key "Netnews Next Line" #k"Downarrow" :mode "News-Headers") +(bind-key "Netnews Previous Line" #k"C-p" :mode "News-Headers") +(bind-key "Netnews Previous Line" #k"Uparrow" :mode "News-Headers") +(bind-key "Netnews Select Message Buffer" #k"hyper-m" :mode "News-Headers") +(bind-key "Netnews Show Article" #k"space" :mode "News-Headers") + + +;;; News-Message. +;;; +(bind-key "Insert Message Region" #k"Hyper-y" :mode "News-Message") +(bind-key "Netnews Message File Message" #k"o" :mode "News-Message") +(bind-key "Netnews Message Keep Buffer" #k"k" :mode "News-Message") +(bind-key "Netnews Message Quit" #k"q" :mode "News-Message") +(bind-key "Netnews Message Scroll Down" #k"space" :mode "News-Message") +(bind-key "Netnews Goto Draft Buffer" #k"hyper-d" :mode "News-Message") +(bind-key "Netnews Goto Headers Buffer" #k"^" :mode "News-Message") +(bind-key "Netnews Goto Headers Buffer" #k"hyper-h" :mode "News-Message") +(bind-key "Netnews Goto Post Buffer" #k"hyper-p" :mode "News-Message") +(bind-key "Scroll Window Up" #k"backspace" :mode "News-Message") + + +;;; Post. +;;; +(bind-key "Netnews Select Message Buffer" #k"hyper-m" :mode "Post") +(bind-key "Netnews Deliver Post" #k"hyper-s" :mode "Post") +(bind-key "Netnews Abort Post" #k"hyper-q" :mode "Post") +(bind-key "Insert Message Buffer" #k"Hyper-y" :mode "Post") + + +;;; News-Browse. + +(bind-key "Netnews Quit Browse" #k"q" :mode "News-Browse") +(bind-key "Netnews Browse Add Group To File" #k"a" :mode "News-Browse") +(bind-key "Netnews Browse Read Group" #k"space" :mode "News-Browse") +(bind-key "Next Line" #k"n" :mode "News-Browse") +(bind-key "Previous Line" #k"p" :mode "News-Browse") + ;;;; Process (Shell). -(bind-key "Confirm Process Input" #k"return" :mode "Process") (bind-key "Shell" #k"control-meta-s") +(bind-key "Confirm Process Input" #k"return" :mode "Process") +(bind-key "Shell Complete Filename" #k"M-escape" :mode "Process") (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-\\") @@ -648,7 +765,7 @@ ;;;; Bufed. -(bind-key "Bufed" #k"control-x control-meta-b")) +(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") @@ -667,7 +784,7 @@ ;;;; Dired. -(bind-key "Dired" #k"control-x control-meta-d")) +(bind-key "Dired" #k"control-x control-meta-d") (bind-key "Dired Delete File and Down Line" #k"d" :mode "Dired") (bind-key "Dired Delete File with Pattern" #k"D" :mode "Dired") diff --git a/hemlock/bit-stream.lisp b/hemlock/bit-stream.lisp index 2d9a3ba41..43c064348 100644 --- a/hemlock/bit-stream.lisp +++ b/hemlock/bit-stream.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/bit-stream.lisp,v 1.1.1.5 1993/08/25 02:23:30 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/bit-stream.lisp,v 1.2 1994/02/11 21:52:51 ram Exp $") ;;; ;;; ********************************************************************** ;;; diff --git a/hemlock/charmacs.lisp b/hemlock/charmacs.lisp index 8f21fc171..6b271f55c 100644 --- a/hemlock/charmacs.lisp +++ b/hemlock/charmacs.lisp @@ -1,65 +1,43 @@ ;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- ;;; ;;; ********************************************************************** -;;; This code was written as part of the Spice Lisp project at -;;; Carnegie-Mellon University, and has been placed in the public domain. -;;; Spice Lisp is currently incomplete and under active development. -;;; If you want to use this code or any part of Spice Lisp, please contact -;;; Scott Fahlman (FAHLMAN@CMUC). +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/charmacs.lisp,v 1.3 1994/02/11 21:52:52 ram Exp $") +;;; ;;; ********************************************************************** ;;; ;;; Implementation specific character-hacking macros and constants. ;;; -(in-package 'hemlock-internals) -(export ' (syntax-char-code-limit command-char-bits-limit - command-char-code-limit search-char-code-limit - do-alpha-chars)) - -;;; This file contains various constants and macros which are -;;; implementation or ASCII dependant. In particular it contains -;;; all the character implementation parameters such as -;;; Command-Char-Bits-Limit, and contains various versions -;;; of char-code which don't check types and omit the top bit -;;; so that various structures can be allocated 128 long instead -;;; of 256, and we don't get errors if a loser visits a binary file. +(in-package "HEMLOCK-INTERNALS") +(export ' (syntax-char-code-limit search-char-code-limit do-alpha-chars)) -;;; There are so many different constants and macros that do the same -;;; thing because in principle the char-code-limit for the syntax -;;; functions is independant of that for the searching functions, etc. +;;; This file contains various constants and macros which are implementation or +;;; ASCII dependant. It contains some versions of CHAR-CODE which do not check +;;; types and ignore the top bit so that various structures can be allocated +;;; 128 long instead of 256, and we don't get errors if a loser visits a binary +;;; file. +;;; +;;; There are so many different constants and macros implemented the same. +;;; This is to separate various mechanisms; for example, in principle the +;;; char-code-limit for the syntax functions is independant of that for the +;;; searching functions +;;; -;;; This file also contains code which adds any implementation specific -;;; character names to the char file's Char-Name-Alist so that there -;;; is a reasonable read-syntax and print-representation for all -;;; characters a user might run across. ;;;; Stuff for the Syntax table functions (syntax) -(defconstant syntax-char-code-limit 128 +(defconstant syntax-char-code-limit char-code-limit "The highest char-code which a character argument to the syntax table functions may have.") -(defconstant syntax-char-code-mask #x+7f - "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 (lisp::%sp-make-fixnum ,char))) -;;;; Stuff for the command interpreter (interp) -;;; -;;; On the Perq we have bits for command bindings, on the VAX there -;;; aren't. The code to interpret them is conditionally compiled -;;; so that the VAX isnt't slowed down. -;;; -;;; Make command-char-code-limit 256 instead of 128 for X keyboard scan-codes. -(defconstant command-char-code-limit 256 - "The upper bound on character codes supported for key bindings.") -(defconstant command-char-bits-limit 16 - "The maximum value of character bits supported for key bindings.") -(defmacro key-char-bits (char) - `(ash (logand #x+F00 (lisp::%sp-make-fixnum ,char)) -8)) -(defmacro key-char-code (char) +(defmacro syntax-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) @@ -67,7 +45,7 @@ (defconstant search-char-code-limit 128 "The exclusive upper bound on significant char-codes for searching.") (defmacro search-char-code (ch) - `(logand (lisp::%sp-make-fixnum ,ch) #x+7F)) + `(logand (char-code ,ch) #x+7F)) ;;; ;;; search-hash-code must be a function with the following properties: ;;; given any character it returns a number between 0 and @@ -76,12 +54,12 @@ ;;; In ASCII this is can be done by ANDing out the 5'th bit. ;;; (defmacro search-hash-code (ch) - `(logand (lisp::%sp-make-fixnum ,ch) #x+5F)) + `(logand (char-code ,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) - `(lisp::fast-char-upcase ,ch)) + `(char-upcase (the base-char ,ch))) diff --git a/hemlock/cursor.lisp b/hemlock/cursor.lisp index c65901953..9173b0c80 100644 --- a/hemlock/cursor.lisp +++ b/hemlock/cursor.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/cursor.lisp,v 1.1.1.6 1993/08/25 02:23:38 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/cursor.lisp,v 1.2 1994/02/11 21:52:53 ram Exp $") ;;; ;;; ********************************************************************** ;;; diff --git a/hemlock/dired.lisp b/hemlock/dired.lisp index 1ce5e2511..2874018ce 100644 --- a/hemlock/dired.lisp +++ b/hemlock/dired.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/dired.lisp,v 1.1.1.6 1993/09/01 09:47:37 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/dired.lisp,v 1.2 1994/02/11 21:52:54 ram Exp $") ;;; ;;; ********************************************************************** ;;; diff --git a/hemlock/diredcoms.lisp b/hemlock/diredcoms.lisp index 6c427ed6b..f9bca8373 100644 --- a/hemlock/diredcoms.lisp +++ b/hemlock/diredcoms.lisp @@ -1,11 +1,14 @@ ;;; -*- Log: hemlock.log; Package: Hemlock -*- ;;; ;;; ********************************************************************** -;;; This code was written as part of the Spice Lisp project at -;;; Carnegie-Mellon University, and has been placed in the public domain. -;;; Spice Lisp is currently incomplete and under active development. -;;; If you want to use this code or any part of Spice Lisp, please contact -;;; Scott Fahlman (FAHLMAN@CMUC). +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/diredcoms.lisp,v 1.3 1994/02/11 21:52:56 ram Exp $") +;;; ;;; ********************************************************************** ;;; ;;; Simple directory editing support. @@ -331,11 +334,8 @@ (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))))))) + (truename (make-pathname :directory (nconc dirs '(:UP))))))) @@ -434,14 +434,12 @@ (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."))) @@ -760,15 +758,17 @@ (push (cons pathname (file-write-date pathname)) marked-files))))))) -;;; ARRAY-ELEMENT-FROM-MARK counts the lines between it and the beginning -;;; of the buffer. The number is used to index vector as if each line -;;; mapped to an element starting with the zero'th element (lines are -;;; numbered starting at 1). +;;; ARRAY-ELEMENT-FROM-MARK -- Internal Interface. +;;; +;;; This counts the lines between it and the beginning of the buffer. The +;;; number is used to index vector as if each line mapped to an element +;;; starting with the zero'th element (lines are numbered starting at 1). +;;; This must use AREF since some modes use this with extendable vectors. ;;; (defun array-element-from-mark (mark vector &optional (error-msg "Invalid line.")) (when (blank-line-p (mark-line mark)) (editor-error error-msg)) - (svref vector + (aref vector (1- (count-lines (region (buffer-start-mark (line-buffer (mark-line mark))) mark))))) @@ -787,7 +787,7 @@ ;;; one directory. ;;; (defun dired-directorify (pathname) - (let ((directory (lisp::predict-name pathname t))) + (let ((directory (ext:unix-namestring pathname))) (if (directoryp directory) directory (pathname (concatenate 'simple-string (namestring directory) "/"))))) diff --git a/hemlock/echocoms.lisp b/hemlock/echocoms.lisp index ab47e05fe..9b8ec8aca 100644 --- a/hemlock/echocoms.lisp +++ b/hemlock/echocoms.lisp @@ -1,18 +1,21 @@ ;;; -*- Log: hemlock.log; Package: Hemlock -*- ;;; ;;; ********************************************************************** -;;; This code was written as part of the Spice Lisp project at -;;; Carnegie-Mellon University, and has been placed in the public domain. -;;; Spice Lisp is currently incomplete and under active development. -;;; If you want to use this code or any part of Spice Lisp, please contact -;;; Scott Fahlman (FAHLMAN@CMUC). +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/echocoms.lisp,v 1.3 1994/02/11 21:52:59 ram Exp $") +;;; ;;; ********************************************************************** ;;; ;;; Echo area commands. ;;; ;;; Written by Rob MacLachlan and Skef Wholey. ;;; -(in-package 'hemlock) +(in-package "HEMLOCK") (defhvar "Beep on Ambiguity" "If non-NIL, beep when completion of a parse is ambiguous." @@ -21,7 +24,7 @@ (defhvar "Ignore File Types" "File types to ignore when trying to complete a filename." :value - (list "fasl" "err" ; Lisp + (list "fasl" "pmaxf" "sparcf" "rtf" "hpf" "axpf" "err" ; Lisp "BAK" "CKP" ; Backups & Checkpoints "PS" "ps" "press" "otl" "dvi" "toc" ; Formatting "bbl" "lof" "idx" "lot" "aux" ; Formatting @@ -85,9 +88,20 @@ (write-line help s) (cond (pns (write-line "Possible completions of what you have typed:" s) - (dolist (pn pns) - (format s " ~A~25T ~A~%" (file-namestring pn) - (directory-namestring pn)))) + (let ((width (- (window-width (current-window)) 27))) + (dolist (pn pns) + (let* ((dir (directory-namestring pn)) + (len (length dir))) + (unless (<= len width) + (let ((slash (position #\/ dir + :start (+ (- len width) 3)))) + (setf dir + (if slash + (concatenate 'string "..." + (subseq dir slash)) + "...")))) + (format s " ~A~25T ~A~%" + (file-namestring pn) dir))))) (t (write-line "There are no possible completions of what you have typed." s)))))) @@ -215,7 +229,6 @@ "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) @@ -251,6 +264,12 @@ (declare (ignore p)) (editor-error)) +(add-hook window-buffer-hook + #'(lambda (window new-buff) + (when (and (eq window *echo-area-window*) + (not (eq new-buff *echo-area-buffer*))) + (editor-error "Can't change echo area window.")))) + (defcommand "Beginning Of Parse" (p) "Moves to immediately after the prompt when in the echo area." "Move the point of the echo area buffer to *parse-starting-mark*." diff --git a/hemlock/eval-server.lisp b/hemlock/eval-server.lisp index 6c9b3b059..9256e9f4b 100644 --- a/hemlock/eval-server.lisp +++ b/hemlock/eval-server.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/eval-server.lisp,v 1.1.1.15 1994/02/04 15:20:29 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/eval-server.lisp,v 1.2 1994/02/11 21:53:00 ram Exp $") ;;; ;;; ********************************************************************** ;;; diff --git a/hemlock/filecoms.lisp b/hemlock/filecoms.lisp index 599a9b1eb..1399dbac1 100644 --- a/hemlock/filecoms.lisp +++ b/hemlock/filecoms.lisp @@ -1,15 +1,19 @@ ;;; -*- Package: Hemlock; Log: hemlock.log -*- ;;; ;;; ********************************************************************** -;;; This code was written as part of the Spice Lisp project at -;;; Carnegie-Mellon University, and has been placed in the public domain. -;;; Spice Lisp is currently incomplete and under active development. -;;; If you want to use this code or any part of Spice Lisp, please contact -;;; Scott Fahlman (FAHLMAN@CMUC). +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/filecoms.lisp,v 1.4 1994/02/11 21:53:02 ram Exp $") +;;; ;;; ********************************************************************** ;;; ;;; This file contains file/buffer manipulating commands. ;;; + (in-package "HEMLOCK") @@ -271,8 +275,8 @@ (unless (eq b buffer) (let ((bpn (buffer-pathname b))) (when (equal bpn buffer-pn) - (message "Buffer ~A also contains ~A." - (buffer-name b) (namestring buffer-pn)) + (loud-message "Buffer ~A also contains ~A." + (buffer-name b) (namestring buffer-pn)) (return))))))) @@ -282,15 +286,15 @@ (defcommand "Revert File" (p) "Unless in Save Mode, reads in the last saved version of the file in - the current buffer. When in Save Mode, reads in the last checkpoint or - the last saved version, whichever is more recent. An argument will always - force Revert File to use the last saved version. In either case, if the - buffer has been modified and \"Revert File Confirm\" is true, then Revert - File will ask for confirmation beforehand. An attempt is made to maintain - the point's relative position." + the current buffer. When in Save Mode, reads in the last checkpoint or + the last saved version, whichever is more recent. An argument will always + force Revert File to use the last saved version. In either case, if the + buffer has been modified and \"Revert File Confirm\" is true, then Revert + File will ask for confirmation beforehand. An attempt is made to maintain + the point's relative position." "With an argument reverts to the last saved version of the file in the - current buffer. Without, reverts to the last checkpoint or last saved - version, whichever is more recent." + current buffer. Without, reverts to the last checkpoint or last saved + version, whichever is more recent." (let* ((buffer (current-buffer)) (buffer-pn (buffer-pathname buffer)) (point (current-point)) @@ -326,7 +330,8 @@ (let* ((buffer-pn (buffer-pathname buffer)) (buffer-pn-date (file-write-date buffer-pn)) (checkpoint-pn (get-checkpoint-pathname buffer)) - (checkpoint-pn-date (file-write-date checkpoint-pn))) + (checkpoint-pn-date (and checkpoint-pn + (file-write-date checkpoint-pn)))) (cond (checkpoint-pn-date (if (> checkpoint-pn-date (or buffer-pn-date 0)) (values checkpoint-pn t) @@ -340,11 +345,11 @@ (defcommand "Find File" (p &optional pathname) "Visit a file in its own buffer. - If the file is already in some buffer, select that buffer, - otherwise make a new buffer with the same name as the file and - read the file into it." + If the file is already in some buffer, select that buffer, + otherwise make a new buffer with the same name as the file and + read the file into it." "Make a buffer containing the file Pathname current, creating a buffer - if necessary. The buffer is returned." + if necessary. The buffer is returned." (declare (ignore p)) (let* ((pn (or pathname (prompt-for-file @@ -369,13 +374,13 @@ :key #'buffer-pathname :test #'equal))) (cond ((not found) (let* ((name (pathname-to-buffer-name trial-pathname)) - (buffer (getstring name *buffer-names*)) - (use (if buffer + (found (getstring name *buffer-names*)) + (use (if found (prompt-for-buffer :prompt "Buffer to use: " :help "Buffer name in use; give another buffer name, or confirm to reuse." - :default buffer :must-exist nil) + :default found :must-exist nil) (make-buffer name))) (buffer (if (stringp use) (make-buffer use) use))) (when (and (buffer-modified buffer) @@ -456,6 +461,7 @@ file exists, set the buffer's pathname to the probed pathname; else, set it to pathname merged with DEFAULT-DIRECTORY. Set \"Pathname Defaults\" to the same thing. Process the file options, and then invoke \"Read File Hook\"." + (setf (buffer-writable buffer) t) (delete-region (buffer-region buffer)) (let* ((pathname (pathname pathname)) (probed-pathname (probe-file pathname))) @@ -778,6 +784,14 @@ (buffer-name buffer) (setf (buffer-writable buffer) (not (buffer-writable buffer)))))) +(defcommand "Set Buffer Writable" (p) + "Make the current buffer modifiable." + "Make the current buffer modifiable." + (declare (ignore p)) + (let ((buffer (current-buffer))) + (setf (buffer-writable buffer) t) + (message "Buffer ~S is now writable." (buffer-name buffer)))) + (defcommand "Kill Buffer" (p &optional buffer-name) "Prompts for a buffer to delete. If the buffer is modified, then let the user save the file before doing so. diff --git a/hemlock/files.lisp b/hemlock/files.lisp index 14167a352..f1cba3585 100644 --- a/hemlock/files.lisp +++ b/hemlock/files.lisp @@ -1,11 +1,14 @@ ;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- ;;; ;;; ********************************************************************** -;;; This code was written as part of the Spice Lisp project at -;;; Carnegie-Mellon University, and has been placed in the public domain. -;;; Spice Lisp is currently incomplete and under active development. -;;; If you want to use this code or any part of Spice Lisp, please contact -;;; Scott Fahlman (FAHLMAN@CMUC). +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/files.lisp,v 1.3 1994/02/11 21:53:04 ram Exp $") +;;; ;;; ********************************************************************** ;;; ;;; Hemlock File manipulation functions. @@ -17,6 +20,21 @@ (export '(read-file write-file)) + +;;;; Utility functions. + +(defun find-char-from-sap (sap start end char) + (declare (type system-area-pointer sap) + (type (integer 0 (#.most-positive-fixnum)) start end) + (type base-char char)) + (do ((index start (1+ index)) + (code (char-code char))) + ((>= index end) nil) + (declare (type (integer 0 #.most-positive-fixnum) index) + (type (unsigned-byte 8) code)) + (when (= (sap-ref-8 sap index) code) + (return index)))) + ;;; Read-File: @@ -25,36 +43,36 @@ (with-mark ((mark mark :left-inserting)) (let* ((tn (truename pathname)) (name (namestring tn)) - (alien ()) + (sap nil) (size 0)) - (declare (fixnum size)) - (multiple-value-bind (fd err) (mach:unix-open name mach:o_rdonly 0) - (if (not (null fd)) - (multiple-value-bind (res dev ino mode nlnk uid gid rdev len) - (mach:unix-fstat fd) - (declare (ignore ino mode nlnk uid gid rdev)) - (setq err ()) - (if (null res) - (setq err dev) - (multiple-value-bind (gr addr) - (mach::vm_allocate lisp::*task-self* - 0 len t) - (gr-error 'mach::vm_allocate gr 'read-file) - (setq alien (lisp::fixnum-to-sap addr)) - (setq size len) - (multiple-value-bind - (bytes err3) - (mach:unix-read fd (lisp::fixnum-to-sap addr) len) - (if (or (null bytes) (not (eq len bytes))) - (setq err err3))))) - (mach:unix-close fd))) - (if err (error "Reading file ~A, unix error ~A." - name (mach:get-unix-error-msg err))) - (when (zerop size) (return-from read-file nil)) - (let* ((sap alien) - (first-line (mark-line mark)) + (declare (fixnum size) + (type (or null system-area-pointer) sap)) + (multiple-value-bind (fd err) (unix:unix-open name unix:o_rdonly 0) + (when fd + (multiple-value-bind (res dev ino mode nlnk uid gid rdev len) + (unix:unix-fstat fd) + (declare (ignore ino mode nlnk uid gid rdev)) + (cond ((null res) + (setq err dev)) + (t + (setf sap (system:allocate-system-memory len)) + (setf size len) + (multiple-value-bind + (bytes err3) + (unix:unix-read fd sap len) + (if (or (null bytes) (not (= len bytes))) + (setq err err3) + (setq err nil)))))) + (unix:unix-close fd)) + (when err + (error "Reading file ~A, unix error ~A." + name (unix:get-unix-error-msg err))) + (when (zerop size) + (return-from read-file nil)) + (let* ((first-line (mark-line mark)) (buffer (line-%buffer first-line)) - (index (%primitive find-character sap 0 size #\newline))) + (index (find-char-from-sap sap 0 size #\newline))) + (declare (type (or null (integer 0 (#.most-positive-fixnum))) index)) (modifying-buffer buffer) (let* ((len (or index size)) (chars (make-string len))) @@ -62,11 +80,9 @@ (insert-string mark chars)) (when index (insert-character mark #\newline) - (do* ((old-index (1+ (the fixnum index)) (1+ (the fixnum index))) - (index (%primitive find-character sap old-index size - #\newline) - (%primitive find-character sap old-index size - #\newline)) + (do* ((old-index (1+ index) (1+ index)) + (index (find-char-from-sap sap old-index size #\newline) + (find-char-from-sap sap old-index size #\newline)) (number (+ (line-number first-line) line-increment) (+ number line-increment)) (previous first-line)) @@ -89,7 +105,7 @@ :previous previous :%buffer buffer :number number - :chars (%primitive sap+ sap old-index) + :chars (system:sap+ sap old-index) :buffered-p (the fixnum (- (the fixnum index) old-index))))) (setf (line-next previous) line) @@ -109,18 +125,25 @@ ;;; Write-File: -(defun write-file (region pathname &key +(defun write-file (region pathname &key append (keep-backup (value ed::keep-backup-files)) access) - "Writes the characters in the Region to the file named by Pathname. - Region is written using a stream opened with :if-exists :rename-and-delete, - but keep-backup, when supplied as non-nil, causes :rename to be supplied - instead of :rename-and-delete. Access is an implementation dependent value - that is suitable for setting pathname's access or protection bits." - (let ((if-exists-action (if keep-backup - :rename - :rename-and-delete))) - (with-open-file (file pathname :direction :output :element-type 'string-char + "Writes the characters in region to the file named by pathname. This writes + region using a stream opened with :if-exists :rename-and-delete, unless + either append or keep-backup is supplied. If append is supplied, this + writes the file opened with :if-exists :append. If keep-backup is supplied, + this writes the file opened with :if-exists :rename. This signals an error + if both append and keep-backup are supplied. Access is an implementation + dependent value that is suitable for setting pathname's access or protection + bits." + (let ((if-exists-action (cond ((and keep-backup append) + (error "Cannot supply non-nil values for ~ + both keep-backup and append.")) + (keep-backup :rename) + (append :append) + (t :rename-and-delete)))) + (with-open-file (file pathname :direction :output + :element-type 'base-char :if-exists if-exists-action) (close-line) (fast-write-file region file)) @@ -132,17 +155,10 @@ ;; If this is ever moved to the beginning of this function to use ;; Unix CREAT to create the file protected initially, they TRUENAME ;; will signal an error, and LISP::PREDICT-NAME will have to be used. - (mach:unix-chmod (namestring (truename pathname)) access) + (unix:unix-chmod (namestring (truename pathname)) access) (unless winp (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) - "Size, in bytes, of each VM page.") + (unix:get-unix-error-msg code))))))) (defun fast-write-file (region file) (let* ((start (region-start region)) @@ -159,44 +175,39 @@ (do ((line (line-next start-line) (line-next line))) ((eq line end-line)) (incf length (1+ (line-length line)))) - (let ((bytes (* *vm-page-size* - (ceiling length *vm-page-size*)))) - (system:gr-bind (address) - (mach:vm_allocate system:*task-self* 0 bytes t) - (unwind-protect - (let ((sap (system:int-sap address))) - (macrolet ((chars (line) - `(if (line-buffered-p ,line) - (line-%chars ,line) - (line-chars ,line)))) + (let ((sap (system:allocate-system-memory length))) + (unwind-protect + (macrolet ((chars (line) + `(if (line-buffered-p ,line) + (line-%chars ,line) + (line-chars ,line)))) + (system:%primitive byte-blt + (chars start-line) start-charpos + sap 0 first-length) + (setf (system:sap-ref-8 sap first-length) + (char-code #\newline)) + (let ((offset (1+ first-length))) + (do ((line (line-next start-line) + (line-next line))) + ((eq line end-line)) + (let ((end (+ offset (line-length line)))) + (system:%primitive byte-blt + (chars line) 0 + sap offset end) + (setf (system:sap-ref-8 sap end) + (char-code #\newline)) + (setf offset (1+ end)))) + (unless (zerop end-charpos) (system:%primitive byte-blt - (chars start-line) start-charpos - sap 0 first-length) - (system:%primitive 8bit-system-set - sap first-length #\newline) - (let ((offset (1+ first-length))) - (do ((line (line-next start-line) - (line-next line))) - ((eq line end-line)) - (let ((end (+ offset (line-length line)))) - (system:%primitive byte-blt - (chars line) 0 - sap offset end) - (system:%primitive 8bit-system-set - sap end #\newline) - (setf offset (1+ end)))) - (unless (zerop end-charpos) - (system:%primitive byte-blt - (chars end-line) 0 - sap offset - (+ offset end-charpos))))) - (multiple-value-bind - (okay errno) - (mach:unix-write (system:fd-stream-fd file) - sap 0 length) - (unless okay - (error "Could not write ~S: ~A" - file - (mach:get-unix-error-msg errno)))) - (system:gr-call mach:vm_deallocate system:*task-self* - address bytes))))))))) + (chars end-line) 0 + sap offset + (+ offset end-charpos)))) + (multiple-value-bind + (okay errno) + (unix:unix-write (system:fd-stream-fd file) + sap 0 length) + (unless okay + (error "Could not write ~S: ~A" + file + (unix:get-unix-error-msg errno))))) + (system:deallocate-system-memory sap length))))))) diff --git a/hemlock/fill.lisp b/hemlock/fill.lisp index c609f764a..6d3d03b83 100644 --- a/hemlock/fill.lisp +++ b/hemlock/fill.lisp @@ -1,11 +1,14 @@ ;;; -*- Log: hemlock.log; Package: Hemlock -*- ;;; ;;; ********************************************************************** -;;; This code was written as part of the Spice Lisp project at -;;; Carnegie-Mellon University, and has been placed in the public domain. -;;; Spice Lisp is currently incomplete and under active development. -;;; If you want to use this code or any part of Spice Lisp, please contact -;;; Scott Fahlman (FAHLMAN@CMUC). +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/fill.lisp,v 1.3 1994/02/11 21:53:06 ram Exp $") +;;; ;;; ********************************************************************** ;;; ;;; Written by Bill Chiles @@ -82,7 +85,6 @@ (setf (character-attribute :sentence-closing-char #\>) 1) - ;;;; -- Commands -- (defcommand "Auto Fill Mode" (p) @@ -118,7 +120,6 @@ (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) @@ -138,7 +139,6 @@ 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) @@ -188,7 +188,6 @@ (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)))) @@ -226,6 +225,7 @@ :value val :buffer (current-buffer)) (message "Fill Prefix now ~:[empty~;~:*~S~]" val))))) +(declaim (optimize (speed 2))); turn off byte compilation. ;;;; -- Auto Filling -- diff --git a/hemlock/group.lisp b/hemlock/group.lisp index a7ba96fbe..9f587fe42 100644 --- a/hemlock/group.lisp +++ b/hemlock/group.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/group.lisp,v 1.1.1.3 1993/08/25 02:08:50 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/group.lisp,v 1.2 1994/02/11 21:53:07 ram Exp $") ;;; ;;; ********************************************************************** ;;; diff --git a/hemlock/htext2.lisp b/hemlock/htext2.lisp index 0294632f0..490ccee69 100644 --- a/hemlock/htext2.lisp +++ b/hemlock/htext2.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/htext2.lisp,v 1.1.1.2 1991/02/08 16:35:07 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/htext2.lisp,v 1.2 1994/02/11 21:53:10 ram Exp $") ;;; ;;; ********************************************************************** ;;; diff --git a/hemlock/htext3.lisp b/hemlock/htext3.lisp index 9f4078739..8a00bf79b 100644 --- a/hemlock/htext3.lisp +++ b/hemlock/htext3.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/htext3.lisp,v 1.1.1.3 1991/11/09 03:05:36 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/htext3.lisp,v 1.2 1994/02/11 21:53:11 ram Exp $") ;;; ;;; ********************************************************************** ;;; diff --git a/hemlock/input.lisp b/hemlock/input.lisp index fa549430f..205fb684c 100644 --- a/hemlock/input.lisp +++ b/hemlock/input.lisp @@ -1,11 +1,14 @@ ;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- ;;; ;;; ********************************************************************** -;;; This code was written as part of the Spice Lisp project at -;;; Carnegie-Mellon University, and has been placed in the public domain. -;;; Spice Lisp is currently incomplete and under active development. -;;; If you want to use this code or any part of Spice Lisp, please contact -;;; Scott Fahlman (FAHLMAN@CMUC). +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/input.lisp,v 1.3 1994/02/11 21:53:12 ram Exp $") +;;; ;;; ********************************************************************** ;;; ;;; This file contains the code that handles input to Hemlock. @@ -186,7 +189,7 @@ ;;; input method (recursively even). ;;; (eval-when (compile eval) -(defmacro editor-input-method-macro (&optional screen-image-trashed-concern) +(defmacro editor-input-method-macro () `(handler-bind ((error #'(lambda (condition) (let ((device (device-hunk-device (window-hunk (current-window))))) @@ -203,10 +206,8 @@ (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)))) + (unless (or (system:serve-event 0) + (internal-redisplay)) (when nrw-fun (funcall nrw-fun t)) (let ((wait (next-scheduled-event-wait))) (if wait (system:serve-event wait) (system:serve-event))))) @@ -223,7 +224,7 @@ ;;;; Editor input from windowing system. - +#+clx (defstruct (windowed-editor-input (:include editor-input (:get #'windowed-get-key-event) @@ -232,18 +233,22 @@ (:clear #'windowed-clear-input)) (:print-function (lambda (s stream d) - (declare (ignore s d write)) + (declare (ignore s d)) (write-string "#<Editor-Window-Input stream>" stream))) (:constructor make-windowed-editor-input (&optional (head (make-input-event)) (tail head)))) hunks) ; List of bitmap-hunks which input to this stream. +#+clx +;;; There's actually no difference from the TTY case... (defun windowed-get-key-event (stream ignore-abort-attempts-p) - (editor-input-method-macro)) + (tty-get-key-event stream ignore-abort-attempts-p)) +#+clx (defun windowed-unget-key-event (key-event stream) (un-event key-event stream)) +#+clx (defun windowed-clear-input (stream) (loop (unless (system:serve-event 0) (return))) (without-interrupts @@ -255,14 +260,16 @@ *free-input-events* next) (setf (editor-input-tail stream) head))))) +#+clx (defun windowed-listen (stream) - (loop (unless (system:serve-event 0) - ;; If nothing is pending, check the queued input. - (return (not (null (input-event-next (editor-input-head stream)))))) + (loop + ;; Don't service anymore events if we just got some input. (when (input-event-next (editor-input-head stream)) - ;; Don't service anymore events if we just got some input. - (return t)))) - + (return t)) + ;; + ;; If nothing is pending, check the queued input. + (unless (system:serve-event 0) + (return (not (null (input-event-next (editor-input-head stream)))))))) ;;;; Editor input from a tty. @@ -282,7 +289,7 @@ fd) (defun tty-get-key-event (stream ignore-abort-attempts-p) - (editor-input-method-macro t)) + (editor-input-method-macro)) (defun tty-unget-key-event (key-event stream) (un-event key-event stream)) @@ -297,11 +304,20 @@ *free-input-events* next) (setf (editor-input-tail stream) head))))) +;;; Note that we never return NIL as long as there are events to be served with +;;; SERVE-EVENT. Thus non-keyboard input (i.e. process output) +;;; effectively causes LISTEN to block until either all the non-keyboard input +;;; has happened, or there is some real keyboard input. +;;; (defun tty-listen (stream) - (cond ((input-event-next (editor-input-head stream)) t) - ((editor-tty-listen stream) t) - (t nil))) - + (loop + ;; Don't service anymore events if we just got some input. + (when (or (input-event-next (editor-input-head stream)) + (editor-tty-listen stream)) + (return t)) + ;; If nothing is pending, check the queued input. + (unless (system:serve-event 0) + (return (not (null (input-event-next (editor-input-head stream)))))))) ;;;; GET-KEY-EVENT, UNGET-KEY-EVENT, LISTEN-EDITOR-INPUT, CLEAR-EDITOR-INPUT. diff --git a/hemlock/kbdmac.lisp b/hemlock/kbdmac.lisp index c97a20ae3..d72036436 100644 --- a/hemlock/kbdmac.lisp +++ b/hemlock/kbdmac.lisp @@ -1,11 +1,14 @@ ;;; -*- Log: hemlock.log; Package: Hemlock -*- ;;; ;;; ********************************************************************** -;;; This code was written as part of the Spice Lisp project at -;;; Carnegie-Mellon University, and has been placed in the public domain. -;;; Spice Lisp is currently incomplete and under active development. -;;; If you want to use this code or any part of Spice Lisp, please contact -;;; Scott Fahlman (FAHLMAN@CMUC). +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/kbdmac.lisp,v 1.3 1994/02/11 21:53:14 ram Exp $") +;;; ;;; ********************************************************************** ;;; ;;; This file contains the implementation of keyboard macros for @@ -115,7 +118,7 @@ (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))) + (let ((string (make-array (length key-vector) :element-type 'base-char))) (dotimes (i (length key-vector) string) (setf (aref string i) (key-event-char (aref key-vector i)))))) diff --git a/hemlock/key-event.lisp b/hemlock/key-event.lisp index 2534d4de5..ef709b237 100644 --- a/hemlock/key-event.lisp +++ b/hemlock/key-event.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/key-event.lisp,v 1.1.1.11 1993/02/22 14:36:24 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/key-event.lisp,v 1.2 1994/02/11 21:53:15 ram Exp $") ;;; ;;; ********************************************************************** ;;; diff --git a/hemlock/killcoms.lisp b/hemlock/killcoms.lisp index 5500d049d..37869ab73 100644 --- a/hemlock/killcoms.lisp +++ b/hemlock/killcoms.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/killcoms.lisp,v 1.1.1.2 1991/02/08 16:35:51 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/killcoms.lisp,v 1.2 1994/02/11 21:53:17 ram Exp $") ;;; ;;; ********************************************************************** ;;; diff --git a/hemlock/line.lisp b/hemlock/line.lisp index 535da8a24..6224c6212 100644 --- a/hemlock/line.lisp +++ b/hemlock/line.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/line.lisp,v 1.1.1.4 1993/08/25 02:23:50 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/line.lisp,v 1.2 1994/02/11 21:53:19 ram Exp $") ;;; ;;; ********************************************************************** ;;; diff --git a/hemlock/linimage.lisp b/hemlock/linimage.lisp index 3fb741f7c..cc7b53828 100644 --- a/hemlock/linimage.lisp +++ b/hemlock/linimage.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/linimage.lisp,v 1.1.1.7 1993/08/25 02:23:53 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/linimage.lisp,v 1.2 1994/02/11 21:53:20 ram Exp $") ;;; ;;; ********************************************************************** ;;; diff --git a/hemlock/lispbuf.lisp b/hemlock/lispbuf.lisp index c79d9734f..4fe80b3d5 100644 --- a/hemlock/lispbuf.lisp +++ b/hemlock/lispbuf.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/lispbuf.lisp,v 1.1.1.4 1991/02/08 16:36:05 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/lispbuf.lisp,v 1.2 1994/02/11 21:53:21 ram Exp $") ;;; ;;; ********************************************************************** ;;; diff --git a/hemlock/lispeval.lisp b/hemlock/lispeval.lisp index cec6a795c..811eb338c 100644 --- a/hemlock/lispeval.lisp +++ b/hemlock/lispeval.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/lispeval.lisp,v 1.1.1.12 1993/09/01 03:29:44 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/lispeval.lisp,v 1.2 1994/02/11 21:53:23 ram Exp $") ;;; ;;; ********************************************************************** ;;; diff --git a/hemlock/lispmode.lisp b/hemlock/lispmode.lisp index 5fab8263b..637522b77 100644 --- a/hemlock/lispmode.lisp +++ b/hemlock/lispmode.lisp @@ -1,11 +1,14 @@ ;;; -*- Log: hemlock.log; Package: Hemlock -*- ;;; ;;; ********************************************************************** -;;; This code was written as part of the Spice Lisp project at -;;; Carnegie-Mellon University, and has been placed in the public domain. -;;; Spice Lisp is currently incomplete and under active development. -;;; If you want to use this code or any part of Spice Lisp, please contact -;;; Scott Fahlman (FAHLMAN@CMUC). +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/lispmode.lisp,v 1.3 1994/02/11 21:53:25 ram Exp $") +;;; ;;; ********************************************************************** ;;; ;;; Hemlock LISP Mode commands @@ -15,10 +18,11 @@ (in-package "HEMLOCK") +(declaim (optimize (speed 2))); turn off byte compilation. -;;;; #### VARIABLES #### -;;; +;;;; Variables and lisp-info structure. + ;;; These routines are used to define, for standard LISP mode, the start and end ;;; of a block to parse. If these need to be changed for a minor mode that sits ;;; on top of LISP mode, simply do a DEFHVAR with the minor mode and give the @@ -35,10 +39,9 @@ :value 'end-of-parse-block) -;;;; #### STRUCTURES #### -;;; -;;; LISP-INFO is the structure used to store the data about the line in its Plist. -;;; +;;; LISP-INFO is the structure used to store the data about the line in its +;;; Plist. +;;; ;;; -> BEGINS-QUOTED, ENDING-QUOTED are both Boolean slots that tell whether ;;; or not a line's begining and/or ending are quoted. ;;; @@ -62,8 +65,8 @@ -;;;; #### MACROS #### -;;; +;;;; Macros. + ;;; The following Macros exist to make it easy to acces the Syntax primitives ;;; without uglifying the code. They were originally written by Maddox. ;;; @@ -154,10 +157,10 @@ `(line-previous ,line))) -;;;; #### PARSING FUNCTIONS ### -;;; -;;; PRE-COMMAND-PARSE-CHECK +;;;; Parsing functions. +;;; PRE-COMMAND-PARSE-CHECK -- Public. +;;; (defun pre-command-parse-check (mark &optional (fer-sure-parse nil)) "Parse the area before the command is actually executed." (with-mark ((top mark) @@ -166,9 +169,8 @@ (funcall (value parse-end-function) bottom) (parse-over-block (mark-line top) (mark-line bottom) fer-sure-parse))) -;;; ;;; PARSE-OVER-BLOCK - +;;; (defun parse-over-block (start-line end-line &optional (fer-sure-parse nil)) "Parse over an area indicated from END-LINE to START-LINE." (let ((test-line start-line) @@ -226,8 +228,7 @@ (setq test-line (line-next test-line))))))) -;;;; #### PARSE BLOCK FINDERS #### -;;; +;;;; Parse block finders. (defhvar "Minimum Lines Parsed" "The minimum number of lines before and after the point parsed by Lisp mode." @@ -288,20 +289,23 @@ (setq line (mark-line mark)))) -;;; PARSE-LISP-LINE-INFO parses through the line doing the following things: -;;; +;;;; PARSE-LISP-LINE-INFO. + +;;; PARSE-LISP-LINE-INFO -- Internal. +;;; +;;; This parses through the line doing the following things: +;;; ;;; Counting/Setting the NET-OPEN-PARENS & NET-CLOSE-PARENS. -;;; +;;; ;;; Making all areas of the line that should be invalid (comments, ;;; char-quotes, and the inside of strings) and such be in ;;; RANGES-TO-IGNORE. ;;; ;;; Set BEGINS-QUOTED and ENDING-QUOTED -;;; - +;;; (defun parse-lisp-line-info (mark line-info prev-line-info) "Parse line and set line information like NET-OPEN-PARENS, NET-CLOSE-PARENS, -RANGES-TO-INGORE, and ENDING-QUOTED." + RANGES-TO-INGORE, and ENDING-QUOTED." (let ((net-open-parens 0) (net-close-parens 0)) (declare (fixnum net-open-parens net-close-parens)) @@ -362,26 +366,23 @@ RANGES-TO-INGORE, and ENDING-QUOTED." (setf (lisp-info-net-close-parens line-info) net-close-parens) (setf (lisp-info-signature-slot line-info) (line-signature (mark-line mark))))) + + -;;;; #### STRING QUOTE UTILITIES #### -;;; -;;; - -;;; -;;; VALID-STRING-QUOTE-P +;;;; String quote utilities. +;;; VALID-STRING-QUOTE-P +;;; (defmacro valid-string-quote-p (mark forwardp) "Return T if the string-quote indicated by MARK is valid." (let ((test-mark (gensym))) `(with-mark ((,test-mark ,mark)) - - ,(unless forwardp ; TEST-MARK should always be right before the - `(mark-before ,test-mark)) ; String-quote to be checked. - + ,(unless forwardp + ;; TEST-MARK should always be right before the String-quote to be + ;; checked. + `(mark-before ,test-mark)) (when (test-char (next-character ,test-mark) :lisp-syntax :string-quote) - (let ((slash-count 0)) - (loop (mark-before ,test-mark) (if (test-char (next-character ,test-mark) :lisp-syntax :char-quote) @@ -418,45 +419,41 @@ RANGES-TO-INGORE, and ENDING-QUOTED." (neighbor-mark ,e-mark ,forwardp))))) -;;; DEAL-WITH-STRING-QUOTE -;;; -;;; Called when a string is begun (i.e. parse hits a #\"). It checks for a -;;; matching quote on the line that MARK points to, and puts the -;;; appropriate area in the RANGES-TO-IGNORE slot and leaves MARK pointing -;;; after this area. The "appropriate area" is from MARK to the end of the -;;; line or the matching string-quote, whichever comes first. +;;;; DEAL-WITH-STRING-QUOTE. +;;; DEAL-WITH-STRING-QUOTE +;;; +;;; Called when a string is begun (i.e. parse hits a #\"). It checks for a +;;; matching quote on the line that MARK points to, and puts the appropriate +;;; area in the RANGES-TO-IGNORE slot and leaves MARK pointing after this area. +;;; The "appropriate area" is from MARK to the end of the line or the matching +;;; string-quote, whichever comes first. +;;; (defun deal-with-string-quote (mark info-struct) "Alter the current line's info struct as necessary as due to encountering a -string quote character." + string quote character." (with-mark ((e-mark mark)) - (cond ((find-valid-string-quote e-mark :forwardp t :cease-at-eol t) - - ;; If matching quote is on this line then mark the area between - ;; the first quote (MARK) and the matching quote as invalid by - ;; pushing its begining and ending into the IGNORE-RANGE. - + ;; If matching quote is on this line then mark the area between the + ;; first quote (MARK) and the matching quote as invalid by pushing + ;; its begining and ending into the IGNORE-RANGE. (push-range (cons (mark-charpos mark) (mark-charpos e-mark)) info-struct) - (setf (lisp-info-ending-quoted info-struct) nil) (mark-after e-mark) (move-mark mark e-mark)) - - ;; If the EOL has been hit before the matching quote then mark - ;; the area from MARK to the EOL as invalid. - + ;; If the EOL has been hit before the matching quote then mark the + ;; area from MARK to the EOL as invalid. (t - (push-range (cons (mark-charpos mark) (1+ (line-length (mark-line mark)))) + (push-range (cons (mark-charpos mark) + (1+ (line-length (mark-line mark)))) info-struct) - ;; The Ending is marked as still being quoted. - (setf (lisp-info-ending-quoted info-struct) t) (line-end mark) nil)))) - + + ;;;; Character validity checking: @@ -469,7 +466,6 @@ string quote character." ;;; the buffer beginning or end), then return both values NIL. ;;; (defun find-ignore-region (mark forwardp) - (declare (fixnum pos)) (flet ((scan (line pos) (declare (fixnum pos)) (let ((info (getf (line-plist line) 'lisp-info))) @@ -537,15 +533,15 @@ string quote character." (setq ,n-won t)))))) -;;;; #### LIST-OFFSETING #### -;;; +;;;; List offseting. + ;;; %LIST-OFFSET allows for BACKWARD-LIST and FORWARD-LIST to be built ;;; with the same existing structure, with the altering of one variable. ;;; This one variable being FORWARDP. ;;; (defmacro %list-offset (actual-mark forwardp &key (extra-parens 0) ) "Expand to code that will go forward one list either backward or forward, -according to the FORWARDP flag." + according to the FORWARDP flag." (let ((mark (gensym))) `(let ((paren-count ,extra-parens)) (declare (fixnum paren-count)) @@ -559,8 +555,10 @@ according to the FORWARDP flag." (case (character-attribute :lisp-syntax ch) (:close-paren (decf paren-count) - ,(when forwardp ; When going forward, an unmatching - `(when (<= paren-count 0) ; close-paren means the end of list. + ,(when forwardp + ;; When going forward, an unmatching close-paren means the + ;; end of list. + `(when (<= paren-count 0) (neighbor-mark ,mark ,forwardp) (move-mark ,actual-mark ,mark) (return t)))) @@ -573,10 +571,10 @@ according to the FORWARDP flag." (return t)))) (:newline - ;; When a #\Newline is hit, then the matching paren must lie on - ;; some other line so drop down into the multiple line balancing - ;; function: QUEST-FOR-BALANCING-PAREN - ;; If no paren seen yet, keep going. + ;; When a #\Newline is hit, then the matching paren must lie + ;; on some other line so drop down into the multiple line + ;; balancing function: QUEST-FOR-BALANCING-PAREN If no paren + ;; seen yet, keep going. (cond ((zerop paren-count)) ((quest-for-balancing-paren ,mark paren-count ,forwardp) (move-mark ,actual-mark ,mark) @@ -742,7 +740,7 @@ according to the FORWARDP flag." -;;;; #### FORM OFFSETING #### +;;;; Form offseting. (defmacro %form-offset (mark forwardp) `(with-mark ((m ,mark)) @@ -799,8 +797,7 @@ according to the FORWARDP flag." -;;; Table of special forms with special indenting requirements. - +;;;; Table of special forms with special indenting requirements. (defhvar "Indent Defanything" "This is the number of special arguments implicitly assumed to be supplied @@ -907,6 +904,47 @@ according to the FORWARDP flag." (defindent "abort" 1) (defindent "continue" 1) +;;; Debug-internals forms. +;;; +(defindent "do-debug-function-blocks" 1) +(defindent "di:do-debug-function-blocks" 1) +(defindent "do-debug-function-variables" 1) +(defindent "di:do-debug-function-variables" 1) +(defindent "do-debug-block-locations" 1) +(defindent "di:do-debug-block-locations" 1) +;;; +;;; Debug-internals conditions +;;; (define these to make uses of HANDLER-CASE indent branches correctly.) +;;; +(defindent "debug-condition" 1) +(defindent "di:debug-condition" 1) +(defindent "no-debug-info" 1) +(defindent "di:no-debug-info" 1) +(defindent "no-debug-function-returns" 1) +(defindent "di:no-debug-function-returns" 1) +(defindent "no-debug-blocks" 1) +(defindent "di:no-debug-blocks" 1) +(defindent "lambda-list-unavailable" 1) +(defindent "di:lambda-list-unavailable" 1) +(defindent "no-debug-variables" 1) +(defindent "di:no-debug-variables" 1) +(defindent "invalid-value" 1) +(defindent "di:invalid-value" 1) +(defindent "ambiguous-variable-name" 1) +(defindent "di:ambiguous-variable-name" 1) +(defindent "debug-error" 1) +(defindent "di:debug-error" 1) +(defindent "unhandled-condition" 1) +(defindent "di:unhandled-condition" 1) +(defindent "unknown-code-location" 1) +(defindent "di:unknown-code-location" 1) +(defindent "unknown-debug-variable" 1) +(defindent "di:unknown-debug-variable" 1) +(defindent "invalid-control-stack-pointer" 1) +(defindent "di:invalid-control-stack-pointer" 1) +(defindent "frame-function-mismatch" 1) +(defindent "di:frame-function-mismatch" 1) + ;;; Xlib forms. ;;; (defindent "with-gcontext" 1) @@ -935,22 +973,37 @@ according to the FORWARDP flag." (defindent "def-c-record" 1) (defindent "defrecord" 1) +;;; Wire forms. +(defindent "remote" 1) +(defindent "wire:remote" 1) +(defindent "remote-value" 1) +(defindent "wire:remote-value" 1) +(defindent "remote-value-bind" 3) +(defindent "wire:remote-value-bind" 3) + -;;; Compute number of spaces which mark should be indented according to -;;; local context and lisp grinding conventions. +;;;; Indentation. +;;; LISP-INDENTATION -- Internal Interface. +;;; (defun lisp-indentation (mark) + "Compute number of spaces which mark should be indented according to + local context and lisp grinding conventions. This assumes mark is at the + beginning of the line to be indented." (with-mark ((m mark) (temp mark)) + ;; See if we are in a quoted context. (unless (valid-spot m nil) - (return-from lisp-indentation - (lisp-generic-indentation m))) + (return-from lisp-indentation (lisp-generic-indentation m))) + ;; Look for the paren that opens the containing form. (unless (backward-up-list m) (return-from lisp-indentation 0)) + ;; Move after the paren, save the start, and find the form name. (mark-after m) (with-mark ((start m)) - (unless (and (scan-char m :lisp-syntax (not (or :space :prefix :char-quote))) + (unless (and (scan-char m :lisp-syntax + (not (or :space :prefix :char-quote))) (test-char (next-character m) :lisp-syntax :constituent)) (return-from lisp-indentation (mark-column start))) (with-mark ((fstart m)) @@ -961,6 +1014,7 @@ according to the FORWARDP flag." (string= fname "DEF" :end1 3) (value indent-defanything))))) (declare (simple-string fname)) + ;; Now that we have the form name, did it have special syntax? (cond (special-args (with-mark ((spec m)) (cond ((and (form-offset spec special-args) @@ -970,28 +1024,96 @@ according to the FORWARDP flag." (mark-column m)) (t (+ (mark-column start) 3))))) + ;; See if the user seems to have altered the editor's + ;; indentation, and if so, try to adhere to it. This usually + ;; happens when you type in a quoted list constant that line + ;; wraps. You want all the items on successive lines to fall + ;; under the first character after the opening paren, not as if + ;; you are calling a function. ((and (form-offset temp -1) - (or (blank-before-p temp) - (not (same-line-p temp fstart))) + (or (blank-before-p temp) (not (same-line-p temp fstart))) (not (same-line-p temp mark))) (unless (blank-before-p temp) (line-start temp) (find-attribute temp :space #'zerop)) (mark-column temp)) + ;; Appears to be a normal form. Is the first arg on the same + ;; line as the form name? ((skip-valid-space m) - (mark-column m)) + (or (lisp-indentation-check-for-local-def + mark temp fstart start t) + (mark-column m))) + ;; Okay, fall under the first character after the opening paren. (t - (mark-column start)))))))) + (or (lisp-indentation-check-for-local-def + mark temp fstart start nil) + (mark-column start))))))))) + +(defhvar "Lisp Indentation Local Definers" + "Forms with syntax like LABELS, MACROLET, etc." + :value '("LABELS" "MACROLET" "FLET")) +;;; LISP-INDENTATION-CHECK-FOR-LOCAL-DEF -- Internal. +;;; +;;; This is a temporary hack to see how it performs. When we are indenting +;;; what appears to be a function call, let's look for FLET or MACROLET to see +;;; if we really are indenting a local definition. If we are, return the +;;; indentation for a DEFUN; otherwise, nil +;;; +;;; Mark is the argument to LISP-INDENTATION. Start is just inside the paren +;;; of what looks like a function call. If we are in an FLET, arg-list +;;; indicates whether the local function's arg-list has been entered, that is, +;;; whether we need to normally indent for a DEFUN body or indent specially for +;;; the arg-list. +;;; +(defun lisp-indentation-check-for-local-def (mark temp1 temp2 start arg-list) + ;; We know this succeeds from LISP-INDENTATION. + (backward-up-list (move-mark temp1 mark)) ;Paren for local definition. + (cond ((and (backward-up-list temp1) ;Paren opening the list of defs + (form-offset (move-mark temp2 temp1) -1) + (mark-before temp2) + (backward-up-list temp1) ;Paren for FLET or MACROLET. + (mark= temp1 temp2)) ;Must be in first arg form. + ;; See if the containing form is named FLET or MACROLET. + (mark-after temp1) + (unless (and (scan-char temp1 :lisp-syntax + (not (or :space :prefix :char-quote))) + (test-char (next-character temp1) :lisp-syntax + :constituent)) + (return-from lisp-indentation-check-for-local-def nil)) + (move-mark temp2 temp1) + (scan-char temp2 :lisp-syntax (not :constituent)) + (let ((fname (nstring-upcase (region-to-string (region temp1 temp2))))) + (cond ((not (member fname (value lisp-indentation-local-definers) + :test #'string=)) + nil) + (arg-list + (1+ (mark-column start))) + (t + (+ (mark-column start) 3))))))) + +;;; LISP-GENERIC-INDENTATION -- Internal. +;;; +;;; LISP-INDENTATION calls this when mark is in a invalid spot, or quoted +;;; context. If we are inside a string, we return the column one greater +;;; than the opening double quote. Otherwise, we just use the indentation +;;; of the first preceding non-blank line. +;;; (defun lisp-generic-indentation (mark) - (let* ((line (mark-line mark)) - (prev (do ((line (line-previous line) (line-previous line))) - ((or (null line) (not (blank-line-p line))) line)))) - (cond (prev - (line-start mark prev) - (find-attribute mark :space #'zerop) - (mark-column mark)) - (t 0)))) + (with-mark ((m mark)) + (form-offset m -1) + (cond ((eq (character-attribute :lisp-syntax (next-character m)) + :string-quote) + (1+ (mark-column m))) + (t + (let* ((line (mark-line mark)) + (prev (do ((line (line-previous line) (line-previous line))) + ((not (and line (blank-line-p line))) line)))) + (cond (prev + (line-start mark prev) + (find-attribute mark :space #'zerop) + (mark-column mark)) + (t 0))))))) ;;; Skip-Valid-Space -- Internal ;;; @@ -1007,8 +1129,10 @@ according to the FORWARDP flag." ((valid-spot mark t) (return mark)))) (mark-after mark))) +(declaim (optimize (speed 0))); byte compile again + -;;;; LISP Mode commands +;;;; Indentation commands and hook functions. (defcommand "Defindent" (p) "Define the Lisp indentation for the current function. @@ -1016,7 +1140,6 @@ 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)) @@ -1034,7 +1157,72 @@ according to the FORWARDP flag." (when (minusp i) (editor-error "Indentation must be non-negative.")) (defindent s i)))))) - (indent-command ())) + (indent-command nil)) + +(defcommand "Indent Form" (p) + "Indent Lisp code in the next form." + "Indent Lisp code in the next form." + (declare (ignore p)) + (let ((point (current-point))) + (pre-command-parse-check point) + (with-mark ((m point)) + (unless (form-offset m 1) (editor-error)) + (lisp-indent-region (region point m) "Indent Form")))) + +;;; LISP-INDENT-REGION -- Internal. +;;; +;;; This indents a region of Lisp code without doing excessive redundant +;;; computation. We parse the entire region once, then scan through doing +;;; indentation on each line. We forcibly reparse each line that we indent so +;;; that the list operations done to determine indentation of subsequent lines +;;; will work. This is done undoably with save1, save2, buf-region, and +;;; undo-region. +;;; +(defun lisp-indent-region (region &optional (undo-text "Lisp region indenting")) + (check-region-query-size region) + (let ((start (region-start region)) + (end (region-end region))) + (with-mark ((m1 start) + (m2 end)) + (funcall (value parse-start-function) m1) + (funcall (value parse-end-function) m2) + (parse-over-block (mark-line m1) (mark-line m2))) + (let* ((first-line (mark-line start)) + (last-line (mark-line end)) + (prev (line-previous first-line)) + (prev-line-info + (and prev (getf (line-plist prev) 'lisp-info))) + (save1 (line-start (copy-mark start :right-inserting))) + (save2 (line-end (copy-mark end :left-inserting))) + (buf-region (region save1 save2)) + (undo-region (copy-region buf-region))) + (with-mark ((bol start :left-inserting)) + (do ((line first-line (line-next line))) + (nil) + (line-start bol line) + (insert-lisp-indentation bol) + (let ((line-info (getf (line-plist line) 'lisp-info))) + (parse-lisp-line-info bol line-info prev-line-info) + (setq prev-line-info line-info)) + (when (eq line last-line) (return nil)))) + (make-region-undo :twiddle undo-text buf-region undo-region)))) + +;;; INDENT-FOR-LISP -- Internal. +;;; +;;; This is the value of "Indent Function" for "Lisp" mode. +;;; +(defun indent-for-lisp (mark) + (line-start mark) + (pre-command-parse-check mark) + (insert-lisp-indentation mark)) + +(defun insert-lisp-indentation (m) + (delete-horizontal-space m) + (funcall (value indent-with-tabs) m (lisp-indentation m))) + + + +;;;; Most "Lisp" mode commands. (defcommand "Beginning of Defun" (p) "Move the point to the beginning of a top-level form. @@ -1257,64 +1445,6 @@ according to the FORWARDP flag." (move-mark point s2))))))) -(defcommand "Indent Form" (p) - "Indent Lisp code in the next form." - "Indent Lisp code in the next form." - (declare (ignore p)) - (let ((point (current-point))) - (pre-command-parse-check point) - (with-mark ((m point)) - (unless (form-offset m 1) (editor-error)) - (lisp-indent-region (region point m) "Indent Form")))) - -;;; LISP-INDENT-REGION indents a region of Lisp code without doing excessive -;;; redundant computation. We parse the entire region once, then scan through -;;; doing indentation on each line. We forcibly reparse each line that we -;;; indent so that the list operations done to determine indentation of -;;; subsequent lines will work. This is done undoably with save1, save2, -;;; buf-region, and undo-region. -;;; -(defun lisp-indent-region (region &optional (undo-text "Lisp region indenting")) - (check-region-query-size region) - (let ((start (region-start region)) - (end (region-end region))) - (with-mark ((m1 start) - (m2 end)) - (funcall (value parse-start-function) m1) - (funcall (value parse-end-function) m2) - (parse-over-block (mark-line m1) (mark-line m2))) - (let* ((first-line (mark-line start)) - (last-line (mark-line end)) - (prev (line-previous first-line)) - (prev-line-info - (and prev (getf (line-plist prev) 'lisp-info))) - (save1 (line-start (copy-mark start :right-inserting))) - (save2 (line-end (copy-mark end :left-inserting))) - (buf-region (region save1 save2)) - (undo-region (copy-region buf-region))) - (with-mark ((bol start :left-inserting)) - (do ((line first-line (line-next line))) - (nil) - (line-start bol line) - (insert-lisp-indentation bol) - (let ((line-info (getf (line-plist line) 'lisp-info))) - (parse-lisp-line-info bol line-info prev-line-info) - (setq prev-line-info line-info)) - (when (eq line last-line) (return nil)))) - (make-region-undo :twiddle undo-text buf-region undo-region)))) - -;;; INDENT-FOR-LISP is the value of "Indent Function" for "Lisp" mode. -;;; -(defun indent-for-lisp (mark) - (line-start mark) - (pre-command-parse-check mark) - (insert-lisp-indentation mark)) - -(defun insert-lisp-indentation (m) - (delete-horizontal-space m) - (funcall (value indent-with-tabs) m (lisp-indentation m))) - - (defcommand "Insert ()" (p) "Insert a pair of parentheses (). With positive argument, puts parentheses around the next p @@ -1342,13 +1472,16 @@ according to the FORWARDP flag." (declare (ignore p)) (let ((point (current-point))) (pre-command-parse-check point) - (with-mark ((m point)) + (with-mark ((m point :left-inserting)) (cond ((scan-char m :lisp-syntax :close-paren) (delete-horizontal-space m) (mark-after m) (move-mark point m) + (delete-mark m) (indent-new-line-command 1)) - (t (editor-error)))))) + (t + (delete-mark m) + (editor-error)))))) (defcommand "Forward Up List" (p) @@ -1392,7 +1525,153 @@ according to the FORWARDP flag." -;;;; "Lisp Mode". +;;;; Filling Lisp comments, strings, and indented text. + +(defhvar "Fill Lisp Comment Paragraph Confirm" + "This determines whether \"Fill Lisp Comment Paragraph\" will prompt for + confirmation to fill contiguous lines with the same initial whitespace when + it is invoked outside of a comment or string." + :value t) + +(defcommand "Fill Lisp Comment Paragraph" (p) + "This fills a flushleft or indented Lisp comment. + This also fills Lisp string literals using the proper indentation as a + filling prefix. When invoked outside of a comment or string, this tries + to fill all contiguous lines beginning with the same initial, non-empty + blankspace. When filling a comment, the current line is used to determine a + fill prefix by taking all the initial whitespace on the line, the semicolons, + and any whitespace following the semicolons." + "Fills a flushleft or indented Lisp comment." + (declare (ignore p)) + (let ((point (current-point))) + (pre-command-parse-check point) + (with-mark ((start point) + (end point) + (m point)) + (let ((commentp (fill-lisp-comment-paragraph-prefix start end))) + (cond (commentp + (fill-lisp-comment-or-indented-text start end)) + ((and (not (valid-spot m nil)) + (form-offset m -1) + (eq (character-attribute :lisp-syntax (next-character m)) + :string-quote)) + (fill-lisp-string m)) + ((or (not (value fill-lisp-comment-paragraph-confirm)) + (prompt-for-y-or-n + :prompt '("Not in a comment or string. Fill contiguous ~ + lines with the same initial whitespace? "))) + (fill-lisp-comment-or-indented-text start end))))))) + +;;; FILL-LISP-STRING -- Internal. +;;; +;;; This fills the Lisp string containing mark as if it had been entered using +;;; Hemlock's Lisp string indentation, "Indent Function" for "Lisp" mode. This +;;; assumes the area around mark has already been PRE-COMMAND-PARSE-CHECK'ed, +;;; and it ensures the string ends before doing any filling. This function +;;; is undo'able. +;;; +(defun fill-lisp-string (mark) + (with-mark ((end mark)) + (unless (form-offset end 1) + (editor-error "Attempted to fill Lisp string, but it doesn't end?")) + (let* ((mark (copy-mark mark :left-inserting)) + (end (copy-mark end :left-inserting)) + (string-region (region mark end)) + (undo-region (copy-region string-region)) + (hack (make-empty-region))) + ;; Generate prefix. + (funcall (value indent-with-tabs) + (region-end hack) (1+ (mark-column mark))) + ;; Skip opening double quote and fill string starting on its own line. + (mark-after mark) + (insert-character mark #\newline) + (line-start mark) + (setf (mark-kind mark) :right-inserting) + (fill-region string-region (region-to-string hack)) + ;; Clean up inserted prefix on first line, delete inserted newline, and + ;; move before the double quote for undo. + (with-mark ((text mark :left-inserting)) + (find-attribute text :whitespace #'zerop) + (delete-region (region mark text))) + (delete-characters mark -1) + (mark-before mark) + ;; Save undo. + (make-region-undo :twiddle "Fill Lisp Comment Paragraph" + string-region undo-region)))) + +;;; FILL-LISP-COMMENT-OR-INDENTED-TEXT -- Internal. +;;; +;;; This fills all contiguous lines around start and end containing fill prefix +;;; designated by the region between start and end. These marks can only be +;;; equal when there is no comment and no initial whitespace. This is a bad +;;; situation since this function in that situation would fill the entire +;;; buffer into one paragraph. This function is undo'able. +;;; +(defun fill-lisp-comment-or-indented-text (start end) + (when (mark= start end) + (editor-error "This command only fills Lisp comments, strings, or ~ + indented text, but this line is flushleft.")) + ;; + ;; Find comment block. + (let* ((prefix (region-to-string (region start end))) + (length (length prefix))) + (declare (simple-string prefix)) + (flet ((frob (mark direction) + (loop + (let* ((line (line-string (mark-line mark))) + (line-len (length line))) + (declare (simple-string line)) + (unless (string= line prefix :end1 (min line-len length)) + (when (= direction -1) + (unless (same-line-p mark end) (line-offset mark 1 0))) + (return))) + (unless (line-offset mark direction 0) + (when (= direction 1) (line-end mark)) + (return))))) + (frob start -1) + (frob end 1)) + ;; + ;; Do it undoable. + (let* ((start1 (copy-mark start :right-inserting)) + (end2 (copy-mark end :left-inserting)) + (region (region start1 end2)) + (undo-region (copy-region region))) + (fill-region region prefix) + (make-region-undo :twiddle "Fill Lisp Comment Paragraph" + region undo-region)))) + +;;; FILL-LISP-COMMENT-PARAGRAPH-PREFIX -- Internal. +;;; +;;; This sets start and end around the prefix to be used for filling. We +;;; assume we are dealing with a comment. If there is no ";", then we try to +;;; find some initial whitespace. If there is a ";", we make sure the line is +;;; blank before it to eliminate ";"'s in the middle of a line of text. +;;; Finally, if we really have a comment instead of some indented text, we skip +;;; the ";"'s and any immediately following whitespace. We allow initial +;;; whitespace, so we can fill strings with the same command. +;;; +(defun fill-lisp-comment-paragraph-prefix (start end) + (line-start start) + (let ((commentp t)) ; Assumes there's a comment. + (unless (to-line-comment (line-start end) ";") + (find-attribute end :whitespace #'zerop) + #|(when (start-line-p end) + (editor-error "No comment on line, and no initial whitespace."))|# + (setf commentp nil)) + (when commentp + (unless (blank-before-p end) + (find-attribute (line-start end) :whitespace #'zerop) + #|(when (start-line-p end) + (editor-error "Semicolon preceded by unindented text."))|# + (setf commentp nil))) + (when commentp + (find-attribute end :lisp-syntax #'(lambda (x) (not (eq x :comment)))) + (find-attribute end :whitespace #'zerop)) + commentp)) + + + +;;;; "Lisp" mode. (defcommand "LISP Mode" (p) "Put current buffer in LISP mode." @@ -1456,6 +1735,23 @@ according to the FORWARDP flag." :mode "Lisp") +(defhvar "Open Paren Finder Function" + "Should be a function that takes a mark for input and returns either NIL + if the mark is not after a close paren, or two (temporary) marks + surrounding the corresponding open paren." + :mode "Lisp" + :value 'lisp-open-paren-finder-function) + +(defun lisp-open-paren-finder-function (mark) + (when (eq (character-attribute :lisp-syntax (previous-character mark)) + :close-paren) + (with-mark ((mark mark)) + (pre-command-parse-check mark) + (if (not (and (valid-spot mark nil) (list-offset mark -1))) + (values nil nil) + (values mark (mark-after (copy-mark mark))))))) + + ;;;; Some mode variables to coordinate with other stuff. diff --git a/hemlock/mh.lisp b/hemlock/mh.lisp index 05b7ea6ab..cf64122b0 100644 --- a/hemlock/mh.lisp +++ b/hemlock/mh.lisp @@ -1,13 +1,16 @@ ;;; -*- Package: Hemlock; Log: hemlock.log -*- -;;; +;;; ;;; ********************************************************************** -;;; This code was written as part of the Spice Lisp project at -;;; Carnegie-Mellon University, and has been placed in the public domain. -;;; Spice Lisp is currently incomplete and under active development. -;;; you want to use this code or any part of Spice Lisp, please contact -;;; Scott Fahlman (FAHLMAN@CS.CMU.EDU). +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/mh.lisp,v 1.4 1994/02/11 21:53:28 ram Exp $") +;;; ;;; ********************************************************************** -;;; +;;; ;;; This is a mailer interface to MH. ;;; ;;; Written by Bill Chiles. @@ -206,7 +209,7 @@ (defhvar "MH Scan Line Form" "This is a pathname of a file containing an MH format expression for headers lines." - :value (pathname "/usr/misc/.lisp/lib/mh-scan")) + :value (pathname "library:mh-scan")) ;;; MESSAGE-HEADERS-TO-REGION uses the MH "scan" utility output headers into ;;; buffer for folder and msgs. @@ -219,7 +222,7 @@ (with-output-to-mark (*standard-output* (region-end region) :full) (mh "scan" `(,folder ,@msgs - "-form" ,(namestring (value mh-scan-line-form)) + "-form" ,(namestring (truename (value mh-scan-line-form))) "-width" ,(number-string (or width (value fill-column))) "-noheader"))) region)) @@ -1124,39 +1127,41 @@ (dolist (w (buffer-windows b)) (update-modeline-field b w :replied-to-message)))))) (maybe-delete-extra-draft-window dbuffer (current-window)) - (let* ((mbuf (value message-buffer)) - (minfo (if mbuf - (variable-value 'message-information :buffer mbuf)))) - (when (and minfo (not (message-info-keep minfo))) - (delete-buffer-if-possible mbuf))) + (let ((mbuf (value message-buffer))) + (when (and mbuf + (not (hemlock-bound-p 'netnews-message-info :buffer mbuf))) + (let ((minfo (variable-value 'message-information :buffer mbuf))) + (when (and minfo (not (message-info-keep minfo))) + (delete-buffer-if-possible mbuf))))) (delete-buffer-if-possible dbuffer)))) (defcommand "Delete Draft and Buffer" (p) - "Delete the current draft message and buffer." - "Delete the current draft message and buffer." + "Delete the current draft and associated message and buffer." + "Delete the current draft and associated message and buffer." (declare (ignore p)) (let ((dinfo (value draft-information)) (dbuffer (current-buffer))) (unless dinfo (editor-error "No draft associated with buffer.")) (maybe-delete-extra-draft-window dbuffer (current-window)) (delete-file (draft-info-pathname dinfo)) - (let* ((mbuf (value message-buffer)) - (minfo (if mbuf - (variable-value 'message-information :buffer mbuf)))) - (when (and minfo (not (message-info-keep minfo))) - (delete-buffer-if-possible mbuf))) - (delete-buffer-if-possible dbuffer))) - -;;; MAYBE-DELETE-EXTRA-DRAFT-WINDOW takes a draft buffer and a window into it -;;; that should not be deleted. If "Split Window Draft" is bound in the buffer, -;;; and there are more than two windows (two windows plus the echo area at -;;; least), then we delete some window if it is not the dbuffer-window or the -;;; echo area window. Blow away the variable, so we don't think this is still -;;; a split window draft buffer. + (let ((mbuf (value message-buffer))) + (when (and mbuf + (not (hemlock-bound-p 'netnews-message-info :buffer mbuf))) + (let ((minfo (variable-value 'message-information :buffer mbuf))) + (when (and minfo (not (message-info-keep minfo))) + (delete-buffer-if-possible mbuf))))) + (delete-buffer-if-possible dbuffer))) + +;;; MAYBE-DELETE-EXTRA-DRAFT-WINDOW -- Internal. +;;; +;;; This takes a draft buffer and a window into it that should not be deleted. +;;; If "Split Window Draft" is bound in the buffer, and there are at least two +;;; windows in dbuffer-window's group, then we delete some window. Blow away +;;; the variable, so we don't think this is still a split window draft buffer. ;;; (defun maybe-delete-extra-draft-window (dbuffer dbuffer-window) (when (and (hemlock-bound-p 'split-window-draft :buffer dbuffer) - ;; Since we now bitmap devices have window groups, this loop is + ;; Since we know bitmap devices have window groups, this loop is ;; more correct than testing the length of *window-list* and ;; accounting for *echo-area-window* being in there. (do ((start dbuffer-window) @@ -1166,7 +1171,6 @@ (delete-window (next-window dbuffer-window)) (delete-variable 'split-window-draft :buffer dbuffer))) - (defcommand "Remail Message" (p) "Prompts for a folder and message to remail. Prompts for a resend-to address string and resend-cc address string. When in a headers buffer, @@ -1303,35 +1307,58 @@ :value 75) (defcommand "Insert Message Region" (p) - "Copy the current region into the associated draft buffer. - When in a message buffer that has an associated draft buffer, the current - active region is copied into the draft buffer. It is filled using \"Message - Insertion Prefix\" and \"Message Insertion Column\". If an argument is - supplied, the filling is inhibited." - "When in a message buffer that has an associated draft buffer, the current - active region is copied into the draft buffer. It is filled using - \"Message Insertion Prefix\" and \"Message Insertion Column\". If an - argument is supplied, the filling is inhibited." - (let ((minfo (value message-information))) - (unless minfo (editor-error "Not in a message buffer.")) - (let ((dbuf (message-info-draft-buf minfo))) - (unless dbuf - (editor-error "Message buffer not associated with any draft buffer.")) - (let* ((region (copy-region (current-region))) - (dbuf-point (buffer-point dbuf)) - (dbuf-mark (copy-mark dbuf-point))) - (if (and (hemlock-bound-p 'split-window-draft :buffer dbuf) - (> (length (the list *window-list*)) 2) - (buffer-windows dbuf)) - (setf (current-buffer) dbuf - (current-window) (car (buffer-windows dbuf))) - (change-to-buffer dbuf)) - (push-buffer-mark dbuf-mark) - (ninsert-region dbuf-point region) - (unless p - (fill-region-by-paragraphs (region dbuf-mark dbuf-point) - (value message-insertion-prefix) - (value message-insertion-column)))))) + "Copy the current region into the associated draft or post buffer. When + in a message buffer that has an associated draft or post buffer, the + current active region is copied into the draft or post buffer. It is + filled using \"Message Insertion Prefix\" and \"Message Insertion + Column\". If an argument is supplied, the filling is inhibited. + If both a draft buffer and post buffer are associated with this, then it + is inserted into the draft buffer." + "When in a message buffer that has an associated draft or post buffer, + the current active region is copied into the post or draft buffer. It is + filled using \"Message Insertion Prefix\" and \"Message Insertion + Column\". If an argument is supplied, the filling is inhibited." + (let* ((minfo (value message-information)) + (nm-info (if (hemlock-bound-p 'netnews-message-info) + (value netnews-message-info))) + (post-buffer (and nm-info (nm-info-post-buffer nm-info))) + (post-info (and post-buffer + (variable-value 'post-info :buffer post-buffer))) + dbuf kind) + (cond (minfo + (setf kind :mail) + (setf dbuf (message-info-draft-buf minfo))) + (nm-info + (setf kind :netnews) + (setf dbuf (or (nm-info-draft-buffer nm-info) + (nm-info-post-buffer nm-info)))) + (t (editor-error "Not in a netnews message or message buffer."))) + (unless dbuf + (editor-error "Message buffer not associated with any draft or post ~ + buffer.")) + (let* ((region (copy-region (current-region))) + (dbuf-point (buffer-point dbuf)) + (dbuf-mark (copy-mark dbuf-point))) + (cond ((and (eq kind :mail) + (hemlock-bound-p 'split-window-draft :buffer dbuf) + (> (length (the list *window-list*)) 2) + (buffer-windows dbuf)) + (setf (current-buffer) dbuf + (current-window) (car (buffer-windows dbuf)))) + ((and (eq kind :netnews) + (and (member (post-info-message-window post-info) + *window-list*) + (member (post-info-reply-window post-info) + *window-list*))) + (setf (current-buffer) dbuf + (current-window) (post-info-reply-window post-info))) + (t (change-to-buffer dbuf))) + (push-buffer-mark dbuf-mark) + (ninsert-region dbuf-point region) + (unless p + (fill-region-by-paragraphs (region dbuf-mark dbuf-point) + (value message-insertion-prefix) + (value message-insertion-column))))) (setf (last-command-type) :ephemerally-active)) @@ -1342,21 +1369,24 @@ :value " ") (defcommand "Insert Message Buffer" (p) - "Insert entire (associated) message buffer into (associated) draft buffer. - When in a draft buffer with an associated message buffer, or when in a - message buffer that has an associated draft buffer, the message buffer is - inserted into the draft buffer. Each inserted line is modified by prefixing - it with \"Message Buffer Insertion Prefix\". If an argument is supplied the - prefixing is inhibited." - "When in a draft buffer with an associated message buffer, or when in a - message buffer that has an associated draft buffer, the message buffer - is inserted into the draft buffer. Each inserted line is modified by - prefixing it with \"Message Buffer Insertion Prefix\". If an argument - is supplied the prefixing is inhibited." + "Insert entire (associated) message buffer into (associated) draft or + post buffer. When in a draft or post buffer with an associated message + buffer, or when in a message buffer that has an associated draft or post + buffer, the message buffer is inserted into the draft buffer. When + there are both an associated draft and post buffer, the text is inserted + into the draft buffer. Each inserted line is modified by prefixing it + with \"Message Buffer Insertion Prefix\". If an argument is supplied + the prefixing is inhibited." + "When in a draft or post buffer with an associated message buffer, or + when in a message buffer that has an associated draft or post buffer, the + message buffer is inserted into the draft buffer. Each inserted line is + modified by prefixing it with \"Message Buffer Insertion Prefix\". If an + argument is supplied the prefixing is inhibited." (let ((minfo (value message-information)) (dinfo (value draft-information)) - mbuf dbuf) + mbuf dbuf message-kind) (cond (minfo + (setf message-kind :mail) (setf dbuf (message-info-draft-buf minfo)) (unless dbuf (editor-error @@ -1364,12 +1394,32 @@ (setf mbuf (current-buffer)) (change-to-buffer dbuf)) (dinfo + (setf message-kind :mail) (setf mbuf (value message-buffer)) (unless mbuf (editor-error "Draft buffer not associated with any message buffer.")) (setf dbuf (current-buffer))) - (t (editor-error "Not in a draft or message buffer."))) + ((hemlock-bound-p 'netnews-message-info) + (setf message-kind :netnews) + (setf mbuf (current-buffer)) + (let ((nm-info (value netnews-message-info))) + (setf dbuf (or (nm-info-draft-buffer nm-info) + (nm-info-post-buffer nm-info))) + (unless dbuf + (editor-error "Message buffer not associated with any draft ~ + or post buffer."))) + (change-to-buffer dbuf)) + ((hemlock-bound-p 'post-info) + (setf message-kind :netnews) + (let ((post-info (value post-info))) + (setf mbuf (post-info-message-buffer post-info)) + (unless mbuf + (editor-error "Post buffer not associated with any message ~ + buffer."))) + (setf dbuf (current-buffer))) + (t (editor-error "Not in a draft, message, news-message, or post ~ + buffer."))) (let* ((dbuf-point (buffer-point dbuf)) (dbuf-mark (copy-mark dbuf-point))) (push-buffer-mark dbuf-mark) @@ -1381,7 +1431,11 @@ (when (mark>= temp dbuf-point) (return)) (insert-string temp prefix) (unless (line-offset temp 1 0) (return))))))) - (insert-message-buffer-cleanup-split-draft dbuf mbuf)) + (ecase message-kind + (:mail + (insert-message-buffer-cleanup-split-draft dbuf mbuf)) + (:netnews + (nn-reply-cleanup-split-windows dbuf)))) (setf (last-command-type) :ephemerally-active)) ;;; INSERT-MESSAGE-BUFFER-CLEANUP-SPLIT-DRAFT tries to delete an extra window @@ -1614,41 +1668,6 @@ (change-to-buffer *new-mail-buffer*)) -(defhvar "Store Password" - "When this is set, the user is only prompted once for his password." - :value nil) - -(defvar *stored-password* nil) - -(defun get-password () - (if (value store-password) - (or *stored-password* - (setf *stored-password* (prompt-for-password))) - (prompt-for-password))) - - -(defhvar "Authenticate Incorporation" - "When this is set (the default), incorporating new mail prompts for a - password to access a remote mail drop." - :value t) -(defhvar "Authentication User Name" - "When incorporating new mail accesses a remote mail drop, this is the user - name supplied for authentication on the remote machine. If this is nil - it is looked up on the local machine." - :value nil) -#| -(defhvar "Authentication Group Name" - "When incorporating new mail accesses a remote mail drop, this is the group - name supplied for authentication on the remote machine. If this is nil - it is looked up on the local machine." - :value nil) -(defhvar "Authentication Account Name" - "When incorporating new mail accesses a remote mail drop, this is the account - name supplied for authentication on the remote machine. If this is nil - it is looked up on the local machine." - :value nil) -|# - (defhvar "Incorporate New Mail Hook" "Functions on this hook are invoked immediately after new mail is incorporated." @@ -1660,27 +1679,10 @@ (unless (new-mail-p) (editor-error "No new mail.")) (let ((args `(,(coerce-folder-name (value new-mail-folder)) ,@(if stream nil '("-silent")) - "-form" ,(namestring (value mh-scan-line-form)) + "-form" ,(namestring (truename (value mh-scan-line-form))) "-width" ,(number-string (value fill-column))))) - (cond ((value authenticate-incorporation) - (let ((password (get-password))) - ;; Since we know there is mail due to above check, look for a - ;; possible password failure since MH or the rfs stuff is stupid. - (multiple-value-bind - (winp error-string) - (let ((*standard-output* (or stream *standard-output*))) - (message "Incorporating new mail ...") - (mh "inc" args :errorp nil :password password - :username (value authentication-user-name))) - (declare (simple-string error-string)) - (unless winp - (when (string= error-string "inc: unable to read" :end1 19) - (setf *stored-password* nil) - (editor-error - "Couldn't read maildrop, possible mistyped password.")) - (editor-error "MH Error -- ~A" error-string))))) - (t (message "Incorporating new mail ...") - (mh "inc" args)))) + (message "Incorporating new mail ...") + (mh "inc" args)) (when (value incorporate-new-mail-hook) (message "Invoking new mail hooks ...")) (invoke-hook incorporate-new-mail-hook)) @@ -2699,32 +2701,24 @@ (defvar *mh-error-output* (make-string-output-stream)) -(defun mh (utility args &key (errorp *signal-mh-errors*) - password username environment) +(defun mh (utility args &key (errorp *signal-mh-errors*) environment) "Runs the MH utility with the list of args (suitable for EXT:RUN-PROGRAM), - outputting to *standard-output*. If password is supplied, then the MH - utility is run with RFS authentication. If username is nil, this looks it - up on the editor's machine. Environment is a list of strings appended with - ext:*environment-list*. This returns t, unless there is an error. - When errorp, this reports any MH errors in the echo area as an editor error, - and this does not return; otherwise, nil and the error output from the MH - utility are returned." + outputting to *standard-output*. Environment is a list of strings + appended with ext:*environment-list*. This returns t, unless there is + an error. When errorp, this reports any MH errors in the echo area as + an editor error, and this does not return; otherwise, nil and the error + output from the MH utility are returned." (fresh-line) - (let* ((utility (namestring (truename - (merge-pathnames utility - (value mh-utility-pathname))))) + (let* ((utility + (namestring + (or (probe-file (merge-pathnames utility + (value mh-utility-pathname))) + utility))) (proc (ext:run-program utility args :output *standard-output* :error *mh-error-output* - :env (append environment ext:*environment-list*) - :before-execve - (if password - #'(lambda () - (mach:rfs-authenticate - (or username - (lisp::lookup-login-name (mach:unix-getuid))) - nil nil password)))))) + :env (append environment ext:*environment-list*)))) (fresh-line) (ext:process-close proc) (cond ((zerop (ext:process-exit-code proc)) @@ -2803,7 +2797,8 @@ (let ((path (mh-profile-component "path"))) (unless path (error "MH profile does not contain a Path component.")) (setf *mh-directory-pathname* - (merge-relative-pathnames path (user-homedir-pathname)))))) + (truename (merge-relative-pathnames path + (user-homedir-pathname))))))) ;;; Profile components. ;;; @@ -2845,12 +2840,14 @@ (setf *mh-profile-pathname* (merge-pathnames (or (cdr (assoc :mh ext:*environment-list*)) ".mh_profile") - (user-homedir-pathname))))) + (truename (user-homedir-pathname)))))) ;;;; Sequence handling. +(declaim (optimize (speed 2))); byte compile off + (defun mark-one-message (folder msg sequence add-or-delete) "Msg is added or deleted to the sequence named sequence in the folder's \".mh_sequence\" file. Add-or-delete is either :add or :delete." @@ -3084,7 +3081,7 @@ (push (format nil "~D-~D" low high) result)))) (nreverse result))) - +(declaim (optimize (speed 0))); byte compile again. ;;;; CMU Common Lisp support. @@ -3096,10 +3093,10 @@ (defun hacking-rename-file (old new) (let ((ses-name1 (namestring old)) (ses-name2 (namestring new))) - (multiple-value-bind (res err) (mach:unix-rename ses-name1 ses-name2) + (multiple-value-bind (res err) (unix:unix-rename ses-name1 ses-name2) (unless res (error "Failed to rename ~A to ~A: ~A." - ses-name1 ses-name2 (mach:get-unix-error-msg err)))))) + ses-name1 ses-name2 (unix:get-unix-error-msg err)))))) ;;; Folder existence and creation. @@ -3111,10 +3108,10 @@ (declare (simple-string folder)) (let* ((folder (strip-folder-name folder)) (pathname (merge-relative-pathnames folder (mh-directory-pathname))) - (ses-name (namestring pathname))) - (multiple-value-bind (winp type) - (mach:unix-subtestname ses-name) - (and winp (eq type :entry_directory))))) + (pf (probe-file pathname))) + (and pf + (null (pathname-name pf)) + (null (pathname-type pf))))) (defun create-folder (folder) "Creates folder directory with default protection #o711 but considers the @@ -3134,11 +3131,11 @@ (setf protection (parse-integer protection :radix 8 :junk-allowed t))) (multiple-value-bind (winp err) - (mach:unix-mkdir name (or protection #o711)) + (unix:unix-mkdir name (or protection #o711)) (unless winp (error "Couldn't make directory ~S: ~A" name - (mach:get-unix-error-msg err))) + (unix:get-unix-error-msg err))) (check-folder-name-table) (setf (getstring folder *folder-name-table*) t)))) @@ -3153,17 +3150,17 @@ (setf *mailbox* (probe-file (or (cdr (assoc :mail ext:*environment-list*)) (cdr (assoc :maildrop ext:*environment-list*)) - (mh-profile-component "mail-drop") + (mh-profile-component "MailDrop") (merge-pathnames (cdr (assoc :user ext:*environment-list*)) "/usr/spool/mail/"))))) (when *mailbox* (multiple-value-bind (success dev ino mode nlink uid gid rdev size atime) - (mach:unix-stat (namestring *mailbox*)) + (unix:unix-stat (namestring *mailbox*)) (declare (ignore dev ino nlink uid gid rdev atime)) (and success - (plusp (logand mach::s_ifreg mode)) + (plusp (logand unix:s-ifreg mode)) (not (zerop size)))))) diff --git a/hemlock/morecoms.lisp b/hemlock/morecoms.lisp index a07e07a23..23a13c0f1 100644 --- a/hemlock/morecoms.lisp +++ b/hemlock/morecoms.lisp @@ -1,11 +1,14 @@ ;;; -*- Log: hemlock.log; Package: Hemlock -*- ;;; ;;; ********************************************************************** -;;; This code was written as part of the Spice Lisp project at -;;; Carnegie-Mellon University, and has been placed in the public domain. -;;; Spice Lisp is currently incomplete and under active development. -;;; If you want to use this code or any part of Spice Lisp, please contact -;;; Scott Fahlman (FAHLMAN@CMUC). +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/morecoms.lisp,v 1.3 1994/02/11 21:53:36 ram Exp $") +;;; ;;; ********************************************************************** ;;; ;;; Written by Bill Chiles and Rob MacLachlan. @@ -136,7 +139,9 @@ (insert-character mark #\space)) (mark-before mark))) ((mark-before mark)) - (t (return))))) + (t + (setq errorp t) + (return))))) (kill-characters point (- n)) (when errorp (editor-error "There were not ~D characters before point." n))))) @@ -273,7 +278,7 @@ "Display stats on allocated storage." "Run Room into a With-Random-Typeout window." (declare (ignore p)) - (with-pop-up-display (*standard-output* :height 19) + (with-pop-up-display (*standard-output*) (room))) @@ -618,7 +623,6 @@ 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)) diff --git a/hemlock/pop-up-stream.lisp b/hemlock/pop-up-stream.lisp index 3e8467470..4c17e462f 100644 --- a/hemlock/pop-up-stream.lisp +++ b/hemlock/pop-up-stream.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/pop-up-stream.lisp,v 1.1.1.2 1991/02/08 16:36:58 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/pop-up-stream.lisp,v 1.2 1994/02/11 21:53:37 ram Exp $") ;;; ;;; ********************************************************************** ;;; diff --git a/hemlock/register.lisp b/hemlock/register.lisp index 89dda633c..42b2a3d0b 100644 --- a/hemlock/register.lisp +++ b/hemlock/register.lisp @@ -1,11 +1,14 @@ ;;; -*- Log: hemlock.log; Package: Hemlock -*- ;;; ;;; ********************************************************************** -;;; This code was written as part of the Spice Lisp project at -;;; Carnegie-Mellon University, and has been placed in the public domain. -;;; Spice Lisp is currently incomplete and under active development. -;;; If you want to use this code or any part of Spice Lisp, please contact -;;; Scott Fahlman (FAHLMAN@CMUC). +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/register.lisp,v 1.3 1994/02/11 21:53:39 ram Exp $") +;;; ;;; ********************************************************************** ;;; ;;; Registers for holding text and positions. @@ -13,7 +16,7 @@ ;;; Written by Dave Touretzky. ;;; Modified by Bill Chiles for Hemlock consistency. ;;; -(in-package 'hemlock) +(in-package "HEMLOCK") @@ -71,7 +74,6 @@ ;;; (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))) diff --git a/hemlock/ring.lisp b/hemlock/ring.lisp index 5176e2b1e..466b3498c 100644 --- a/hemlock/ring.lisp +++ b/hemlock/ring.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/ring.lisp,v 1.1.1.4 1993/08/25 02:23:57 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/ring.lisp,v 1.2 1994/02/11 21:53:39 ram Exp $") ;;; ;;; ********************************************************************** ;;; diff --git a/hemlock/rompsite.lisp b/hemlock/rompsite.lisp index d4b66d775..3a645a20f 100644 --- a/hemlock/rompsite.lisp +++ b/hemlock/rompsite.lisp @@ -1,22 +1,35 @@ ;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- ;;; ;;; ********************************************************************** -;;; This code was written as part of the Spice Lisp project at -;;; Carnegie-Mellon University, and has been placed in the public domain. -;;; Spice Lisp is currently incomplete and under active development. -;;; If you want to use this code or any part of Spice Lisp, please contact -;;; Scott Fahlman (FAHLMAN@CMUC). +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/rompsite.lisp,v 1.4 1994/02/11 21:53:41 ram Exp $") +;;; ;;; ********************************************************************** ;;; ;;; "Site dependent" stuff for the editor while on the IBM RT PC machine. ;;; +;;; Stuff to set up the packages Hemlock uses. +;;; +(in-package "HEMLOCK-INTERNALS" + :nicknames '("HI") + :use '("LISP" "EXTENSIONS" "SYSTEM")) +;;; +(in-package "HEMLOCK" + :nicknames '("ED") + :use '("LISP" "HEMLOCK-INTERNALS" "EXTENSIONS" "SYSTEM")) +;;; (in-package "SYSTEM") - -(export '(without-hemlock)) - - -(in-package "HEMLOCK-INTERNALS" :nicknames '("HI")) +(export '(without-hemlock %sp-byte-blt %sp-find-character + %sp-find-character-with-attribute + %sp-reverse-find-character-with-attribute)) +;;; +(in-package "HI") (export '(show-mark editor-sleep *input-transcript* fun-defined-from-pathname editor-describe-function pause-hemlock store-cut-string @@ -99,7 +112,7 @@ (defhvar "Cursor Bitmap File" "File to read to setup cursors for Hemlock windows. The mask is found by merging this name with \".mask\"." - :value "/usr/misc/.lisp/lib/hemlock11.cursor") + :value "library:hemlock11.cursor") (defhvar "Enter Window Hook" "When the mouse enters an editor window, this hook is invoked. These functions take the Hemlock Window as an argument." @@ -133,37 +146,26 @@ ;;; MERGE-RELATIVE-PATHNAMES takes a pathname that is either absolute or ;;; relative to default-dir, merging it as appropriate and returning a definite -;;; directory pathname. If the component comes back with a trailing slash, we -;;; have to remove it to get the MERGE-PATHNAMES to work correctly. The result -;;; must have a trailing slash. +;;; directory pathname. +;;; +;;; This function isn't really needed anymore now that merge-pathnames does +;;; this, but the semantics are slightly different. So it's easier to just +;;; keep this around instead of changing all the uses of it. ;;; (defun merge-relative-pathnames (pathname default-directory) "Merges pathname with default-directory. If pathname is not absolute, it is assumed to be relative to default-directory. The result is always a directory." - (setf pathname (pathname pathname)) - (flet ((return-with-slash (pathname) - (let ((ns (namestring pathname))) - (declare (simple-string ns)) - (if (char= #\/ (schar ns (1- (length ns)))) - pathname - (pathname (concatenate 'simple-string ns "/")))))) - (let ((dir (pathname-directory pathname))) - (if dir - (let ((dev (pathname-device pathname))) - (if (eq dev :absolute) - (return-with-slash pathname) - (return-with-slash - (make-pathname :device (pathname-device default-directory) - :directory - (concatenate - 'simple-vector - (pathname-directory default-directory) - dir) - :defaults pathname)))) - (return-with-slash (merge-pathnames pathname default-directory)))))) + (let ((pathname (merge-pathnames pathname default-directory))) + (if (directoryp pathname) + pathname + (pathname (concatenate 'simple-string + (namestring pathname) + "/"))))) (defun directoryp (pathname) + "Returns whether pathname names a directory, that is whether it has no + name and no type components." (not (or (pathname-name pathname) (pathname-type pathname)))) @@ -181,33 +183,42 @@ ;;; (defvar *editor-windowed-input* nil) - ;;; These are used for selecting X events. -;;; -(defconstant group-interesting-xevents - '(:structure-notify)) +#+clx +(eval-when (compile load eval) + (defconstant group-interesting-xevents + '(:structure-notify))) +#+clx (defconstant group-interesting-xevents-mask (apply #'xlib:make-event-mask group-interesting-xevents)) -(defconstant child-interesting-xevents - '(:key-press :button-press :button-release :structure-notify :exposure - :enter-window :leave-window)) +#+clx +(eval-when (compile load eval) + (defconstant child-interesting-xevents + '(:key-press :button-press :button-release :structure-notify :exposure + :enter-window :leave-window))) +#+clx (defconstant child-interesting-xevents-mask (apply #'xlib:make-event-mask child-interesting-xevents)) -(defconstant random-typeout-xevents - '(:key-press :button-press :button-release :enter-window :leave-window - :exposure)) +#+clx +(eval-when (compile load eval) + (defconstant random-typeout-xevents + '(:key-press :button-press :button-release :enter-window :leave-window + :exposure))) +#+clx (defconstant random-typeout-xevents-mask (apply #'xlib:make-event-mask random-typeout-xevents)) + +#+clx (proclaim '(special ed::*open-paren-highlight-font* ed::*active-region-highlight-font*)) -(defparameter lisp-fonts-pathnames - '("/usr/misc/.lisp/lib/fonts/" - "/afs/cs.cmu.edu/unix/rt_mach/omega/usr/misc/.lisp/lib/fonts/")) +#+clx +(defparameter lisp-fonts-pathnames '("library:fonts/")) +(proclaim '(special *editor-input* *real-editor-input*)) (proclaim '(special *editor-input* *real-editor-input*)) @@ -217,12 +228,12 @@ ;;; lisp. It sets up process specific data structures. ;;; (defun init-raw-io (display) + #-clx (declare (ignore display)) (setf *editor-windowed-input* nil) - (cond (display + (cond #+clx + (display (setf *editor-windowed-input* (ext:open-clx-display display)) (setf *editor-input* (make-windowed-editor-input)) - (ext:carefully-add-font-paths *editor-windowed-input* - lisp-fonts-pathnames) (setup-font-family *editor-windowed-input* (variable-value 'ed::default-font) "8x13u" "8x13bold")) @@ -245,6 +256,7 @@ ;;; font-map-size should be defined in font.lisp, but SETUP-FONT-FAMILY would ;;; assume it to be special, issuing a nasty warning. ;;; +#+clx (defconstant font-map-size 16 "The number of possible fonts in a font-map.") @@ -255,6 +267,7 @@ ;;; in lieu of "Active Region Highlighting Font" and "Open Paren Highlighting ;;; Font" when these are defined. ;;; +#+clx (defun setup-font-family (display default-font default-highlight-font default-open-paren-font) (let* ((font-family (make-font-family :map (make-array font-map-size @@ -293,6 +306,7 @@ ;;; level, we want to deal with this error here returning nil if the font ;;; couldn't be opened. ;;; +#+clx (defun setup-one-font (display font-name font-family-map index) (handler-case (let ((font (xlib:open-font display (namestring font-name)))) (xlib:display-finish-output display) @@ -301,7 +315,6 @@ (warn "Cannot open font -- ~S" font-name) nil))) - ;;;; HEMLOCK-BEEP. @@ -313,36 +326,40 @@ (defun tty-beep (&optional device stream) (declare (ignore device stream)) (when (variable-value 'ed::bell-style) - (mach:unix-write 1 *editor-bell* 0 1))) + (unix:unix-write 1 *editor-bell* 0 1))) (proclaim '(special *current-window*)) ;;; BITMAP-BEEP is used in Hemlock for beeping when running under windowed ;;; input. ;;; -(defun bitmap-beep (display stream) +#+clx +(defun bitmap-beep (device stream) (declare (ignore stream)) - (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. - ))) - + (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. + )))) + +#+clx (proclaim '(special *foreground-background-xor*)) +#+clx (defun flash-window-border (window) (let* ((hunk (window-hunk window)) (xwin (bitmap-hunk-xwindow hunk)) @@ -358,17 +375,20 @@ (bottom-y (- h top-border))) (xlib:with-gcontext (gcontext :function xlib::boole-xor :foreground *foreground-background-xor*) - (dotimes (i 8) - (xlib:draw-rectangle xwin gcontext 0 0 side-border h t) - (xlib:display-force-output display) - (xlib:draw-rectangle xwin gcontext side-border bottom-y - top-width top-border t) - (xlib:display-force-output display) - (xlib:draw-rectangle xwin gcontext right-x 0 side-border h t) + (flet ((zot () + (xlib:draw-rectangle xwin gcontext 0 0 side-border h t) + (xlib:draw-rectangle xwin gcontext side-border bottom-y + top-width top-border t) + (xlib:draw-rectangle xwin gcontext right-x 0 side-border h t) + (xlib:draw-rectangle xwin gcontext side-border 0 + top-width top-border t))) + (zot) (xlib:display-force-output display) - (xlib:draw-rectangle xwin gcontext side-border 0 top-width top-border t) + (sleep 0.1) + (zot) (xlib:display-force-output display))))) +#+clx (defun flash-window (window) (let* ((hunk (window-hunk window)) (xwin (bitmap-hunk-xwindow hunk)) @@ -381,15 +401,14 @@ :foreground *foreground-background-xor*) (xlib:draw-rectangle xwin gcontext 0 0 width height t) (xlib:display-force-output display) + (sleep 0.1) (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) (bitmap-device-display device) stream))) + (funcall (device-beep device) device stream))) @@ -452,6 +471,7 @@ (cond ((not *editor-windowed-input*) ,@body) (t + #+clx (ext:with-clx-event-handling (*editor-windowed-input* #'ext:object-set-event-handler) ,@body))))) @@ -469,6 +489,7 @@ ;;; Maybe bury/unbury hemlock window when we go to and from Lisp. ;;; This should do something more sophisticated when we know what that is. ;;; +#+clx (defun default-hemlock-window-mngt (display on) (let ((xparent (window-group-xparent (bitmap-hunk-window-group (window-hunk *current-window*)))) @@ -482,7 +503,7 @@ (setf (xlib:window-priority xparent) :below)))) (xlib:display-force-output display)) -(defvar *hemlock-window-mngt* #'default-hemlock-window-mngt +(defvar *hemlock-window-mngt* nil;#'default-hemlock-window-mngt "This function is called by HEMLOCK-WINDOW, passing its arguments. This may be nil.") @@ -503,7 +524,7 @@ ;;;; Current terminal character translation. -(defconstant termcap-file "/etc/termcap") +(defvar termcap-file "/etc/termcap") @@ -666,6 +687,7 @@ t) (t nil))) +#+clx (defun bitmap-show-mark (window x y time) (cond ((listen-editor-input *editor-input*)) (x (let* ((hunk (window-hunk window)) @@ -679,7 +701,6 @@ t)) (t nil))) - ;;;; Function description and defined-from. @@ -688,23 +709,26 @@ ;;; not defined in some file, then nil is returned. ;;; (defun fun-defined-from-pathname (function) - "Takes a symbol or function and returns the pathname for the file the function - was defined in. If it was not defined in some file, nil is returned." - (typecase function - (symbol (fun-defined-from-pathname (careful-symbol-function function))) - (compiled-function - (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))) + "Takes a symbol or function and returns the pathname for the file the + function was defined in. If it was not defined in some file, nil is + returned." + (flet ((frob (code) + (let ((info (kernel:%code-debug-info code))) + (when info + (let ((sources (c::debug-info-source info))) + (when sources + (let ((source (car sources))) + (when (eq (c::debug-source-from source) :file) + (c::debug-source-name source))))))))) + (typecase function + (symbol (fun-defined-from-pathname (fdefinition function))) + (kernel:byte-closure + (fun-defined-from-pathname (kernel:byte-closure-function function))) + (kernel:byte-function + (frob (c::byte-function-component function))) + (function + (frob (kernel:function-code-header (kernel:%function-self function)))) + (t nil)))) (defvar *editor-describe-stream* @@ -729,7 +753,8 @@ *standard-output*." (describe fun) (when (and (compiled-function-p fun) - (not (eq (%primitive header-ref fun %function-name-slot) sym))) + (not (eq (kernel:%function-name (kernel:%closure-function fun)) + sym))) (let ((doc (documentation sym 'function))) (when doc (format t "~&Function documentation for ~S:" sym) @@ -743,31 +768,38 @@ ;;;; X Stuff. - ;;; Setting window cursors ... ;;; +#+clx (proclaim '(special *default-foreground-pixel* *default-background-pixel*)) +#+clx (defvar *hemlock-cursor* nil "Holds cursor for Hemlock windows.") ;;; DEFINE-WINDOW-CURSOR in shoved on the "Make Window Hook". ;;; +#+clx (defun define-window-cursor (window) (setf (xlib:window-cursor (bitmap-hunk-xwindow (window-hunk window))) *hemlock-cursor*)) ;;; These are set in INIT-BITMAP-SCREEN-MANAGER and REVERSE-VIDEO-HOOK-FUN. ;;; +#+clx (defvar *cursor-foreground-color* nil) +#+clx (defvar *cursor-background-color* nil) +#+clx (defun make-white-color () (xlib:make-color :red 1.0 :green 1.0 :blue 1.0)) +#+clx (defun make-black-color () (xlib:make-color :red 0.0 :green 0.0 :blue 0.0)) ;;; GET-HEMLOCK-CURSOR is used in INIT-BITMAP-SCREEN-MANAGER to load the ;;; hemlock cursor for DEFINE-WINDOW-CURSOR. ;;; +#+clx (defun get-hemlock-cursor (display) (when *hemlock-cursor* (xlib:free-cursor *hemlock-cursor*)) (let* ((cursor-file (truename (variable-value 'ed::cursor-bitmap-file))) @@ -785,6 +817,7 @@ (xlib:free-pixmap cursor-pixmap) (when mask-pixmap (xlib:free-pixmap mask-pixmap))))) +#+clx (defun get-cursor-pixmap (root pathname) (let* ((image (xlib:read-bitmap-file pathname)) (pixmap (xlib:create-pixmap :width 16 :height 16 @@ -801,9 +834,11 @@ ;;; Setting up grey borders ... ;;; +#+clx (defparameter hemlock-grey-bitmap-data '(#*10 #*01)) +#+clx (defun get-hemlock-grey-pixmap (display) (let* ((screen (xlib:display-default-screen display)) (depth (xlib:screen-root-depth screen)) @@ -826,26 +861,29 @@ ;;; Cut Buffer manipulation ... ;;; +#+clx (defun store-cut-string (display string) (check-type string simple-string) (setf (xlib:cut-buffer display) string)) +#+clx (defun fetch-cut-string (display) (xlib:cut-buffer display)) ;;; Window naming ... ;;; +#+clx (defun set-window-name-for-buffer-name (buffer new-name) (dolist (ele (buffer-windows buffer)) (xlib:set-standard-properties (bitmap-hunk-xwindow (window-hunk ele)) :icon-name new-name))) +#+clx (defun set-window-name-for-window-buffer (window new-buffer) (xlib:set-standard-properties (bitmap-hunk-xwindow (window-hunk window)) :icon-name (buffer-name new-buffer))) - ;;;; Some hacks for supporting Hemlock under Mach. @@ -864,44 +902,28 @@ (cdr (assoc :termcap *environment-list* :test #'eq))) - -(defvar *editor-buffer* (make-string 256)) - ;;; GET-EDITOR-TTY-INPUT reads from stream's Unix file descriptor queuing events ;;; in the stream's queue. ;;; (defun get-editor-tty-input (fd) - (let* ((buf *editor-buffer*) - (len (mach:unix-read fd buf 256)) - (i 0)) - (declare (simple-string buf) (fixnum len i)) - (loop - (when (>= i len) (return t)) - (q-event *real-editor-input* - (ext:char-key-event (schar buf i))) - (incf i)))) - -;;; This is used to get listening during smart redisplay to pick up input -;;; in between displaying each line by listening longer (or slowing down -;;; line output depending on your model). 10-20 seems to be good for 9600 -;;; baud, and 250 seems to do it with 1200 baud. -;;; -(defparameter listen-iterations-hack 1) ; 10-20 seems to really pick up input. + (alien:with-alien ((buf (alien:array c-call:unsigned-char 256))) + (multiple-value-bind + (len errno) + (unix:unix-read fd (alien:alien-sap buf) 256) + (declare (type (or null fixnum) len)) + (unless len + (error "Problem with tty input: ~S" + (unix:get-unix-error-msg errno))) + (dotimes (i len t) + (q-event *real-editor-input* + (ext:char-key-event (code-char (alien:deref buf i)))))))) (defun editor-tty-listen (stream) - (mach::with-trap-arg-block mach::int1 nc - (dotimes (i listen-iterations-hack nil) - (multiple-value-bind (val err) - (mach::Unix-ioctl (tty-editor-input-fd stream) - mach::FIONREAD - (lisp::alien-value-sap - mach::int1)) - (declare (ignore err)) - (when (and val - (> (alien-access (mach::int1-int (alien-value nc))) 0)) - (return t)))))) - - + (alien:with-alien ((nc c-call:int)) + (and (unix:unix-ioctl (tty-editor-input-fd stream) + unix::FIONREAD + (alien:alien-sap (alien:addr nc))) + (> nc 0)))) (defvar old-flags) @@ -909,157 +931,233 @@ (defvar old-ltchars) +#+hpux +(progn + (defvar old-c-iflag) + (defvar old-c-oflag) + (defvar old-c-cflag) + (defvar old-c-lflag) + (defvar old-c-cc)) + (defun setup-input () (let ((fd *editor-file-descriptor*)) - (when (mach:unix-isatty 0) - (mach:with-trap-arg-block mach:sgtty sg + (when (unix:unix-isatty 0) + #+hpux + (alien:with-alien ((tios (alien:struct unix:termios))) (multiple-value-bind (val err) - (mach:unix-ioctl fd mach:TIOCGETP - (lisp::alien-value-sap mach:sgtty)) - (if (null val) - (error "Could not get tty information, unix error ~S." - (mach:get-unix-error-msg err))) - (let ((flags (alien-access (mach::sgtty-flags (alien-value sg))))) - (setq old-flags flags) - (setf (alien-access (mach::sgtty-flags (alien-value sg))) - (logand (logior flags mach::tty-cbreak) - (lognot mach::tty-echo) - (lognot mach::tty-crmod))) - (multiple-value-bind - (val err) - (mach:unix-ioctl fd mach:TIOCSETP - (lisp::alien-value-sap mach:sgtty)) - (if (null val) - (error "Could not set tty information, unix error ~S." - (mach:get-unix-error-msg err))))))) - (mach:with-trap-arg-block mach:tchars tc + (unix:unix-tcgetattr fd (alien:alien-sap tios)) + (when (null val) + (error "Could not tcgetattr, unix error ~S." + (unix:get-unix-error-msg err)))) + (setf old-c-iflag (alien:slot tios 'unix:c-iflag)) + (setf old-c-oflag (alien:slot tios 'unix:c-oflag)) + (setf old-c-cflag (alien:slot tios 'unix:c-cflag)) + (setf old-c-lflag (alien:slot tios 'unix:c-lflag)) + (setf old-c-cc + (vector (alien:deref (alien:slot tios 'unix:c-cc) unix:vdsusp) + (alien:deref (alien:slot tios 'unix:c-cc) unix:veof) + (alien:deref (alien:slot tios 'unix:c-cc) unix:vintr) + (alien:deref (alien:slot tios 'unix:c-cc) unix:vquit) + (alien:deref (alien:slot tios 'unix:c-cc) unix:vstart) + (alien:deref (alien:slot tios 'unix:c-cc) unix:vstop) + (alien:deref (alien:slot tios 'unix:c-cc) unix:vsusp) + (alien:deref (alien:slot tios 'unix:c-cc) unix:vmin) + (alien:deref (alien:slot tios 'unix:c-cc) unix:vtime))) + (setf (alien:slot tios 'unix:c-lflag) + (logand (alien:slot tios 'unix:c-lflag) + (lognot (logior unix:tty-echo unix:tty-icanon)))) + (setf (alien:slot tios 'unix:c-iflag) + (logand (alien:slot tios 'unix:c-iflag) + (lognot (logior unix:tty-icrnl unix:tty-ixon)))) + (setf (alien:slot tios 'unix:c-oflag) + (logand (alien:slot tios 'unix:c-oflag) (lognot unix:tty-ocrnl))) + (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vdsusp) #xff) + (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:veof) #xff) + (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vintr) + (if *editor-windowed-input* #xff 28)) + (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vquit) #xff) + (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vstart) #xff) + (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vstop) #xff) + (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vsusp) #xff) + (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vmin) 1) + (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vtime) 0) + (multiple-value-bind + (val err) + (unix:unix-tcsetattr fd unix:tcsaflush (alien:alien-sap tios)) + (when (null val) + (error "Could not tcsetattr, unix error ~S." + (unix:get-unix-error-msg err))))) + #-hpux + (alien:with-alien ((sg (alien:struct unix:sgttyb))) (multiple-value-bind (val err) - (mach:unix-ioctl fd mach:TIOCGETC - (lisp::alien-value-sap mach:tchars)) - (if (null val) - (error "Could not get tty tchars information, unix error ~S." - (mach:get-unix-error-msg err))) - (setq old-tchars - (vector (alien-access (mach::tchars-intrc (alien-value tc))) - (alien-access (mach::tchars-quitc (alien-value tc))) - (alien-access (mach::tchars-startc (alien-value tc))) - (alien-access (mach::tchars-stopc (alien-value tc))) - (alien-access (mach::tchars-eofc (alien-value tc))) - (alien-access (mach::tchars-brkc (alien-value tc)))))) - (setf (alien-access (mach::tchars-intrc (alien-value tc))) + (unix:unix-ioctl fd unix:TIOCGETP (alien:alien-sap sg)) + (unless val + (error "Could not get tty information, unix error ~S." + (unix:get-unix-error-msg err)))) + (let ((flags (alien:slot sg 'unix:sg-flags))) + (setq old-flags flags) + (setf (alien:slot sg 'unix:sg-flags) + (logand #-hpux (logior flags unix:tty-cbreak) + (lognot unix:tty-echo) + (lognot unix:tty-crmod))) + (multiple-value-bind + (val err) + (unix:unix-ioctl fd unix:TIOCSETP (alien:alien-sap sg)) + (if (null val) + (error "Could not set tty information, unix error ~S." + (unix:get-unix-error-msg err)))))) + #-hpux + (alien:with-alien ((tc (alien:struct unix:tchars))) + (multiple-value-bind + (val err) + (unix:unix-ioctl fd unix:TIOCGETC (alien:alien-sap tc)) + (unless val + (error "Could not get tty tchars information, unix error ~S." + (unix:get-unix-error-msg err)))) + (setq old-tchars + (vector (alien:slot tc 'unix:t-intrc) + (alien:slot tc 'unix:t-quitc) + (alien:slot tc 'unix:t-startc) + (alien:slot tc 'unix:t-stopc) + (alien:slot tc 'unix:t-eofc) + (alien:slot tc 'unix:t-brkc))) + (setf (alien:slot tc 'unix:t-intrc) (if *editor-windowed-input* -1 28)) - (setf (alien-access (mach::tchars-quitc (alien-value tc))) -1) - (setf (alien-access (mach::tchars-startc (alien-value tc))) -1) - (setf (alien-access (mach::tchars-stopc (alien-value tc))) -1) - (setf (alien-access (mach::tchars-eofc (alien-value tc))) -1) - (setf (alien-access (mach::tchars-brkc (alien-value tc))) -1) + (setf (alien:slot tc 'unix:t-quitc) -1) + (setf (alien:slot tc 'unix:t-startc) -1) + (setf (alien:slot tc 'unix:t-stopc) -1) + (setf (alien:slot tc 'unix:t-eofc) -1) + (setf (alien:slot tc 'unix:t-brkc) -1) (multiple-value-bind (val err) - (mach:unix-ioctl fd mach:TIOCSETC - (lisp::alien-value-sap mach:tchars)) - (if (null val) (error "Failed to set tchars, unix error ~S." - (mach:get-unix-error-msg err))))) - (mach:with-trap-arg-block mach:ltchars tc + (unix:unix-ioctl fd unix:TIOCSETC (alien:alien-sap tc)) + (unless val + (error "Failed to set tchars, unix error ~S." + (unix:get-unix-error-msg err))))) + + ;; Needed even under HpUx to suppress dsuspc. + (alien:with-alien ((tc (alien:struct unix:ltchars))) (multiple-value-bind (val err) - (mach:unix-ioctl fd mach:TIOCGLTC - (lisp::alien-value-sap mach:ltchars)) - (if (null val) - (error "Could not get tty ltchars information, unix error ~S." - (mach:get-unix-error-msg err))) - (setq old-ltchars - (vector (alien-access (mach::ltchars-suspc (alien-value tc))) - (alien-access (mach::ltchars-dsuspc (alien-value tc))) - (alien-access (mach::ltchars-rprntc (alien-value tc))) - (alien-access (mach::ltchars-flushc (alien-value tc))) - (alien-access (mach::ltchars-werasc (alien-value tc))) - (alien-access (mach::ltchars-lnextc (alien-value tc)))))) - (setf (alien-access (mach::ltchars-suspc (alien-value tc))) -1) - (setf (alien-access (mach::ltchars-dsuspc (alien-value tc))) -1) - (setf (alien-access (mach::ltchars-rprntc (alien-value tc))) -1) - (setf (alien-access (mach::ltchars-flushc (alien-value tc))) -1) - (setf (alien-access (mach::ltchars-werasc (alien-value tc))) -1) - (setf (alien-access (mach::ltchars-lnextc (alien-value tc))) -1) + (unix:unix-ioctl fd unix:TIOCGLTC (alien:alien-sap tc)) + (unless val + (error "Could not get tty ltchars information, unix error ~S." + (unix:get-unix-error-msg err)))) + (setq old-ltchars + (vector (alien:slot tc 'unix:t-suspc) + (alien:slot tc 'unix:t-dsuspc) + (alien:slot tc 'unix:t-rprntc) + (alien:slot tc 'unix:t-flushc) + (alien:slot tc 'unix:t-werasc) + (alien:slot tc 'unix:t-lnextc))) + (setf (alien:slot tc 'unix:t-suspc) -1) + (setf (alien:slot tc 'unix:t-dsuspc) -1) + (setf (alien:slot tc 'unix:t-rprntc) -1) + (setf (alien:slot tc 'unix:t-flushc) -1) + (setf (alien:slot tc 'unix:t-werasc) -1) + (setf (alien:slot tc 'unix:t-lnextc) -1) (multiple-value-bind (val err) - (mach:unix-ioctl fd mach:TIOCSLTC - (lisp::alien-value-sap mach:ltchars)) - (if (null val) (error "Failed to set ltchars, unix error ~S." - (mach:get-unix-error-msg err)))))))) + (unix:unix-ioctl fd unix:TIOCSLTC (alien:alien-sap tc)) + (unless val + (error "Failed to set ltchars, unix error ~S." + (unix:get-unix-error-msg err)))))))) - (defun reset-input () - (when (mach:unix-isatty 0) - (if (boundp 'old-flags) - (let ((fd *editor-file-descriptor*)) - (mach:with-trap-arg-block mach:sgtty sg + (when (unix:unix-isatty 0) + (let ((fd *editor-file-descriptor*)) + #+hpux + (when (boundp 'old-c-lflag) + (alien:with-alien ((tios (alien:struct unix:termios))) + (multiple-value-bind + (val err) + (unix:unix-tcgetattr fd (alien:alien-sap tios)) + (when (null val) + (error "Could not tcgetattr, unix error ~S." + (unix:get-unix-error-msg err)))) + (setf (alien:slot tios 'unix:c-iflag) old-c-iflag) + (setf (alien:slot tios 'unix:c-oflag) old-c-oflag) + (setf (alien:slot tios 'unix:c-cflag) old-c-cflag) + (setf (alien:slot tios 'unix:c-lflag) old-c-lflag) + (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vdsusp) + (svref old-c-cc 0)) + (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:veof) + (svref old-c-cc 1)) + (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vintr) + (svref old-c-cc 2)) + (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vquit) + (svref old-c-cc 3)) + (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vstart) + (svref old-c-cc 4)) + (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vstop) + (svref old-c-cc 5)) + (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vsusp) + (svref old-c-cc 6)) + (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vmin) + (svref old-c-cc 7)) + (setf (alien:deref (alien:slot tios 'unix:c-cc) unix:vtime) + (svref old-c-cc 8)) + (multiple-value-bind + (val err) + (unix:unix-tcsetattr fd unix:tcsaflush (alien:alien-sap tios)) + (when (null val) + (error "Could not tcsetattr, unix error ~S." + (unix:get-unix-error-msg err)))))) + #-hpux + (when (boundp 'old-flags) + (alien:with-alien ((sg (alien:struct unix:sgttyb))) + (multiple-value-bind + (val err) + (unix:unix-ioctl fd unix:TIOCGETP (alien:alien-sap sg)) + (unless val + (error "Could not get tty information, unix error ~S." + (unix:get-unix-error-msg err))) + (setf (alien:slot sg 'unix:sg-flags) old-flags) (multiple-value-bind (val err) - (mach:unix-ioctl fd mach:TIOCGETP - (lisp::alien-value-sap mach:sgtty)) - (if (null val) - (error "Could not get tty information, unix error ~S." - (mach:get-unix-error-msg err))) - (setf (alien-access (mach::sgtty-flags (alien-value sg))) - old-flags) - (multiple-value-bind - (val err) - (mach:unix-ioctl fd mach:TIOCSETP - (lisp::alien-value-sap mach:sgtty)) - (if (null val) - (error "Could not set tty information, unix error ~S." - (mach:get-unix-error-msg err)))))) - (cond ((and (boundp 'old-tchars) - (simple-vector-p old-tchars) - (eq (length old-tchars) 6)) - (mach:with-trap-arg-block mach:tchars tc - (setf (alien-access (mach::tchars-intrc (alien-value tc))) - (svref old-tchars 0)) - (setf (alien-access (mach::tchars-quitc (alien-value tc))) - (svref old-tchars 1)) - (setf (alien-access (mach::tchars-startc (alien-value tc))) - (svref old-tchars 2)) - (setf (alien-access (mach::tchars-stopc (alien-value tc))) - (svref old-tchars 3)) - (setf (alien-access (mach::tchars-eofc (alien-value tc))) - (svref old-tchars 4)) - (setf (alien-access (mach::tchars-brkc (alien-value tc))) - (svref old-tchars 5)) - (multiple-value-bind - (val err) - (mach:unix-ioctl fd mach:TIOCSETC - (lisp::alien-value-sap mach:tchars)) - (if (null val) - (error "Failed to set tchars, unix error ~S." - (mach:get-unix-error-msg err))))))) - (cond ((and (boundp 'old-ltchars) - (simple-vector-p old-ltchars) - (eq (length old-ltchars) 6)) - (mach:with-trap-arg-block mach:ltchars tc - (setf (alien-access (mach::ltchars-suspc (alien-value tc))) - (svref old-ltchars 0)) - (setf (alien-access (mach::ltchars-dsuspc (alien-value tc))) - (svref old-ltchars 1)) - (setf (alien-access (mach::ltchars-rprntc (alien-value tc))) - (svref old-ltchars 2)) - (setf (alien-access (mach::ltchars-flushc (alien-value tc))) - (svref old-ltchars 3)) - (setf (alien-access (mach::ltchars-werasc (alien-value tc))) - (svref old-ltchars 4)) - (setf (alien-access (mach::ltchars-lnextc (alien-value tc))) - (svref old-ltchars 5)) - (multiple-value-bind - (val err) - (mach:unix-ioctl fd mach:TIOCSLTC - (lisp::alien-value-sap mach:ltchars)) - (if (null val) - (error "Failed to set ltchars, unix error ~S." - (mach:get-unix-error-msg err))))))))))) - + (unix:unix-ioctl fd unix:TIOCSETP (alien:alien-sap sg)) + (unless val + (error "Could not set tty information, unix error ~S." + (unix:get-unix-error-msg err))))))) + #-hpux + (when (and (boundp 'old-tchars) + (simple-vector-p old-tchars) + (eq (length old-tchars) 6)) + (alien:with-alien ((tc (alien:struct unix:tchars))) + (setf (alien:slot tc 'unix:t-intrc) (svref old-tchars 0)) + (setf (alien:slot tc 'unix:t-quitc) (svref old-tchars 1)) + (setf (alien:slot tc 'unix:t-startc) (svref old-tchars 2)) + (setf (alien:slot tc 'unix:t-stopc) (svref old-tchars 3)) + (setf (alien:slot tc 'unix:t-eofc) (svref old-tchars 4)) + (setf (alien:slot tc 'unix:t-brkc) (svref old-tchars 5)) + (multiple-value-bind + (val err) + (unix:unix-ioctl fd unix:TIOCSETC (alien:alien-sap tc)) + (unless val + (error "Failed to set tchars, unix error ~S." + (unix:get-unix-error-msg err)))))) + + (when (and (boundp 'old-ltchars) + (simple-vector-p old-ltchars) + (eq (length old-ltchars) 6)) + (alien:with-alien ((tc (alien:struct unix:ltchars))) + (setf (alien:slot tc 'unix:t-suspc) (svref old-ltchars 0)) + (setf (alien:slot tc 'unix:t-dsuspc) (svref old-ltchars 1)) + (setf (alien:slot tc 'unix:t-rprntc) (svref old-ltchars 2)) + (setf (alien:slot tc 'unix:t-flushc) (svref old-ltchars 3)) + (setf (alien:slot tc 'unix:t-werasc) (svref old-ltchars 4)) + (setf (alien:slot tc 'unix:t-lnextc) (svref old-ltchars 5)) + (multiple-value-bind + (val err) + (unix:unix-ioctl fd unix:TIOCSLTC (alien:alien-sap tc)) + (unless val + (error "Failed to set ltchars, unix error ~S." + (unix:get-unix-error-msg err))))))))) (defun pause-hemlock () "Pause hemlock and pop out to the Unix Shell." - (mach:unix-kill (mach:unix-getpid) mach:sigtstp) + (system:without-hemlock + (unix:unix-kill (unix:unix-getpid) :sigstop)) T) diff --git a/hemlock/screen.lisp b/hemlock/screen.lisp index e9251a7d9..65f98d135 100644 --- a/hemlock/screen.lisp +++ b/hemlock/screen.lisp @@ -1,11 +1,14 @@ ;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- ;;; ;;; ********************************************************************** -;;; This code was written as part of the Spice Lisp project at -;;; Carnegie-Mellon University, and has been placed in the public domain. -;;; Spice Lisp is currently incomplete and under active development. -;;; If you want to use this code or any part of Spice Lisp, please contact -;;; Scott Fahlman (FAHLMAN@CMUC). +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/screen.lisp,v 1.3 1994/02/11 21:53:44 ram Exp $") +;;; ;;; ********************************************************************** ;;; ;;; Written by Bill Chiles. @@ -42,17 +45,20 @@ ;;;; Window operations. -(defun make-window (start &key - (modelinep t) - (device nil) - window +(defun make-window (start &key (modelinep t) (device nil) window + (proportion .5) (font-family *default-font-family*) - (ask-user nil) - x y + (ask-user nil) x y (width (value ed::default-window-width)) (height (value ed::default-window-height))) - "Make a window that displays text starting at the mark Start. The default - action is to split the current window to make room for the new window. + "Make a window that displays text starting at the mark start. The default + action is to make the new window a proportion of the current window's height + to make room for the new window. + + Proportion determines what proportion of the current window's height + the new window will use. The current window retains whatever space left + after accommodating the new one. The default is to split the current window + in half. Modelinep specifies whether the window should display buffer modelines. @@ -74,7 +80,7 @@ (let* ((device (or device (device-hunk-device (window-hunk (current-window))))) (window (funcall (device-make-window device) device start modelinep window font-family - ask-user x y width height))) + ask-user x y width height proportion))) (unless window (editor-error "Could not make a window.")) (invoke-hook ed::make-window-hook window) window)) @@ -188,7 +194,7 @@ (list (make-modeline-field :name :more-prompt :function #'(lambda (buffer window) - (declare (ignore buffer window)) + (declare (ignore window)) (ecase *more-prompt-action* (:more "--More--") (:flush "--Flush--") diff --git a/hemlock/search1.lisp b/hemlock/search1.lisp index 8a85603a9..a172ea45b 100644 --- a/hemlock/search1.lisp +++ b/hemlock/search1.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/search1.lisp,v 1.1.1.4 1992/01/06 16:24:15 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/search1.lisp,v 1.2 1994/02/11 21:53:45 ram Exp $") ;;; ;;; ********************************************************************** ;;; diff --git a/hemlock/shell.lisp b/hemlock/shell.lisp index 1ca0e0405..791f47ee4 100644 --- a/hemlock/shell.lisp +++ b/hemlock/shell.lisp @@ -1,11 +1,14 @@ ;;; -*- Log: hemlock.log; Package: Hemlock -*- ;;; ;;; ********************************************************************** -;;; This code was written as part of the Spice Lisp project at -;;; Carnegie-Mellon University, and has been placed in the public domain. -;;; Spice Lisp is currently incomplete and under active development. -;;; If you want to use this code or any part of Spice Lisp, please contact -;;; Scott Fahlman (FAHLMAN@CMUC). +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/shell.lisp,v 1.3 1994/02/11 21:53:46 ram Exp $") +;;; ;;; ********************************************************************** ;;; ;;; Hemlock command level support for processes. @@ -25,7 +28,7 @@ (defhvar "Process Output Stream" "The process structure for this buffer." :buffer buffer - :value (make-hemlock-output-stream mark)) + :value (make-hemlock-output-stream mark :full)) (defhvar "Interactive History" "A ring of the regions input to an interactive mode (Eval or Typescript)." :buffer buffer @@ -45,6 +48,122 @@ (defmode "Process" :major-p nil :setup-function #'setup-process-buffer) + + +;;;; Shell-filter streams. + +;;; We use shell-filter-streams to capture text going from the shell process to +;;; a Hemlock output stream. They pass character and misc operations through +;;; to the attached hemlock-output-stream. The string output function scans +;;; the string for ^A_____^B, denoting a change of directory. +;;; +;;; The following aliases in a .cshrc file are required for using filename +;;; completion: +;;; alias cd 'cd \!* ; echo ""`pwd`"/"' +;;; alias popd 'popd \!* ; echo ""`pwd`"/"' +;;; alias pushd 'pushd \!* ; echo ""`pwd`"/"' +;;; + +(defstruct (shell-filter-stream + (:include stream + (:out #'shell-filter-out) + (:sout #'shell-filter-string-out) + (:misc #'shell-filter-output-misc)) + (:print-function print-shell-filter-stream) + (:constructor + make-shell-filter-stream (buffer hemlock-stream))) + ;; The buffer where output will be going + buffer + ;; The Hemlock stream to which output will be directed + hemlock-stream) + + +;;; PRINT-SHELL-FILTER-STREAM -- Internal +;;; +;;; Function for printing a shell-filter-stream. +;;; +(defun print-shell-filter-stream (s stream d) + (declare (ignore d s)) + (write-string "#<Shell filter stream>" stream)) + + +;;; SHELL-FILTER-OUT -- Internal +;;; +;;; This is the character-out handler for the shell-filter-stream. +;;; It writes the character it is given to the underlying +;;; hemlock-output-stream. +;;; +(defun shell-filter-out (stream character) + (write-char character (shell-filter-stream-hemlock-stream stream))) + + +;;; SHELL-FILTER-OUTPUT-MISC -- Internal +;;; +;;; This will also simply pass the output request on the the +;;; attached hemlock-output-stream. +;;; +(defun shell-filter-output-misc (stream operation &optional arg1 arg2) + (let ((hemlock-stream (shell-filter-stream-hemlock-stream stream))) + (funcall (hi::hemlock-output-stream-misc hemlock-stream) + hemlock-stream operation arg1 arg2))) + + +;;; CATCH-CD-STRING -- Internal +;;; +;;; Scans String for the sequence ^A...^B. Returns as multiple values +;;; the breaks in the string. If the second start/end pair is nil, there +;;; was no cd sequence. +;;; +(defun catch-cd-string (string start end) + (declare (simple-string string)) + (let ((cd-start (position (code-char 1) string :start start :end end))) + (if cd-start + (let ((cd-end (position (code-char 2) string :start cd-start :end end))) + (if cd-end + (values start cd-start cd-end end) + (values start end nil nil))) + (values start end nil nil)))) + +;;; SHELL-FILTER-STRING-OUT -- Internal +;;; +;;; The string output function for shell-filter-stream's. +;;; Any string containing a ^A...^B is caught and assumed to be +;;; the path-name of the new current working directory. This is +;;; removed from the orginal string and the result is passed along +;;; to the Hemlock stream. +;;; +(defun shell-filter-string-out (stream string start end) + (declare (simple-string string)) + (let ((hemlock-stream (shell-filter-stream-hemlock-stream stream)) + (buffer (shell-filter-stream-buffer stream))) + + (multiple-value-bind (start1 end1 start2 end2) + (catch-cd-string string start end) + (write-string string hemlock-stream :start start1 :end end1) + (when start2 + (write-string string hemlock-stream :start (+ 2 start2) :end end2) + (let ((cd-string (subseq string (1+ end1) start2))) + (setf (variable-value 'current-working-directory :buffer buffer) + (pathname cd-string))))))) + + +;;; FILTER-TILDES -- Internal +;;; +;;; Since COMPLETE-FILE does not seem to deal with ~'s in the filename +;;; this function expands them to a full path name. +;;; +(defun filter-tildes (name) + (declare (simple-string name)) + (if (char= (schar name 0) #\~) + (concatenate 'simple-string + (if (or (= (length name) 1) + (char= (schar name 1) #\/)) + (cdr (assoc :home *environment-list*)) + "/usr/") + (subseq name 1)) + name)) + + ;;;; Support for handling input before the prompt in process buffers. @@ -65,6 +184,7 @@ :value "Interrupt and throw to end of buffer?" :mode "Process") + ;;;; Some Global Variables. @@ -114,7 +234,7 @@ (defun set-current-shell () (let ((old-buffer (value current-shell)) (first-old-shell (do-strings (var val *shell-names* nil) - (declare (ignore var val)) + (declare (ignore val)) (return var)))) (when (and (not old-buffer) (not first-old-shell)) (editor-error "Nothing to set current shell to.")) @@ -183,7 +303,7 @@ ,command) :help "Where output from this process will appear.") (new-shell-name))) - (buffer (make-buffer + (temp (make-buffer buffer-name :modes '("Fundamental" "Process") :delete-hook @@ -192,23 +312,32 @@ (setf (value current-shell) nil)) (delete-string (buffer-name buffer) *shell-names*) (kill-process (variable-value 'process - :buffer buffer))))))) - (unless buffer - (setf buffer (getstring buffer-name *buffer-names*)) - (buffer-end (buffer-point buffer))) + :buffer buffer)))))) + (buffer (or temp (getstring buffer-name *buffer-names*))) + (stream (variable-value 'process-output-stream :buffer buffer)) + (output-stream + ;; If we re-used an old shell buffer, this isn't necessary. + (if (hemlock-output-stream-p stream) + (setf (variable-value 'process-output-stream :buffer buffer) + (make-shell-filter-stream buffer stream)) + stream))) + (buffer-end (buffer-point buffer)) (defhvar "Process" "The process for Shell and Process buffers." :buffer buffer :value (ext::run-program "/bin/sh" (list "-c" command) :wait nil - :pty (variable-value 'process-output-stream - :buffer buffer) + :pty output-stream :env (frob-environment-list (car (buffer-windows buffer))) :status-hook #'(lambda (process) (declare (ignore process)) (update-process-buffer buffer)) :input t :output t)) + (defhvar "Current Working Directory" + "The pathname of the current working directory for this buffer." + :buffer buffer + :value (default-directory)) (setf (getstring buffer-name *shell-names*) buffer) (update-process-buffer buffer) (when (and (not (value current-shell)) set-current-shell-p) @@ -267,7 +396,7 @@ (ecase (ext:process-status process) (:running "running") (:stopped "stopped") - (:signaled "killed by signal ~D" (mach:unix-signal-name + (:signaled "killed by signal ~D" (unix:unix-signal-name (ext:process-exit-code process))) (:exited (format nil "exited with status ~D" (ext:process-exit-code process))))))) @@ -308,6 +437,37 @@ ;; Move "Buffer Input Mark" to end of buffer. (move-mark (region-start input-region) (region-end input-region))))) +(defcommand "Shell Complete Filename" (p) + "Attempts to complete the filename immediately preceding the point. + It will beep if the result of completion is not unique." + "Attempts to complete the filename immediately preceding the point. + It will beep if the result of completion is not unique." + (declare (ignore p)) + (unless (hemlock-bound-p 'current-working-directory) + (editor-error "Shell filename completion only works in shells.")) + (let ((point (current-point))) + (with-mark ((start point)) + (pre-command-parse-check start) + (unless (form-offset start -1) (editor-error "Can't grab filename.")) + (when (member (next-character start) '(#\" #\' #\< #\>)) + (mark-after start)) + (let* ((name-region (region start point)) + (fragment (filter-tildes (region-to-string name-region))) + (dir (default-directory)) + (shell-dir (value current-working-directory))) + (multiple-value-bind (filename unique) + (unwind-protect + (progn + (setf (default-directory) shell-dir) + (complete-file fragment :defaults shell-dir)) + (setf (default-directory) dir)) + (cond (filename + (delete-region name-region) + (insert-string point (namestring filename)) + (when (not unique) + (editor-error))) + (t (editor-error "No such file exists.")))))))) + (defcommand "Kill Main Process" (p) "Kills the process in the current buffer." "Kills the process in the current buffer." @@ -353,7 +513,7 @@ (unless (hemlock-bound-p 'process :buffer (current-buffer)) (editor-error "Not in a process buffer.")) (let ((stream (ext:process-pty (value process)))) - (write-char (int-char 4) stream) + (write-char (code-char 4) stream) (force-output stream))) (defcommand "Interrupt Buffer Subprocess" (p) @@ -385,7 +545,6 @@ (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/spell-aug.lisp b/hemlock/spell-aug.lisp index 9e0c9abaa..2bdbe9db5 100644 --- a/hemlock/spell-aug.lisp +++ b/hemlock/spell-aug.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/spell-aug.lisp,v 1.1.1.4 1993/08/25 02:34:08 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/spell-aug.lisp,v 1.2 1994/02/11 21:53:48 ram Exp $") ;;; ;;; ********************************************************************** ;;; diff --git a/hemlock/spell-build.lisp b/hemlock/spell-build.lisp index 92ccc55bd..62fda7977 100644 --- a/hemlock/spell-build.lisp +++ b/hemlock/spell-build.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/spell-build.lisp,v 1.1.1.7 1993/08/25 02:41:08 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/spell-build.lisp,v 1.2 1994/02/11 21:53:49 ram Exp $") ;;; ;;; ********************************************************************** ;;; diff --git a/hemlock/spell-corr.lisp b/hemlock/spell-corr.lisp index a2bb420a2..0aba55154 100644 --- a/hemlock/spell-corr.lisp +++ b/hemlock/spell-corr.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/spell-corr.lisp,v 1.1.1.9 1993/08/25 02:40:00 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/spell-corr.lisp,v 1.2 1994/02/11 21:53:51 ram Exp $") ;;; ;;; ********************************************************************** ;;; diff --git a/hemlock/spell-rt.lisp b/hemlock/spell-rt.lisp index dd5bb7609..59d10f524 100644 --- a/hemlock/spell-rt.lisp +++ b/hemlock/spell-rt.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/spell-rt.lisp,v 1.1.1.7 1993/08/25 02:40:34 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/spell-rt.lisp,v 1.2 1994/02/11 21:53:53 ram Exp $") ;;; ;;; ********************************************************************** ;;; diff --git a/hemlock/spellcoms.lisp b/hemlock/spellcoms.lisp index 8b8d35840..e2f2cf4f6 100644 --- a/hemlock/spellcoms.lisp +++ b/hemlock/spellcoms.lisp @@ -1,11 +1,14 @@ ;;; -*- Log: hemlock.log; Package: Hemlock -*- ;;; ;;; ********************************************************************** -;;; This code was written as part of the Spice Lisp project at -;;; Carnegie-Mellon University, and has been placed in the public domain. -;;; Spice Lisp is currently incomplete and under active development. -;;; If you want to use this code or any part of Spice Lisp, please contact -;;; Scott Fahlman (FAHLMAN@CMUC). +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/spellcoms.lisp,v 1.3 1994/02/11 21:53:54 ram Exp $") +;;; ;;; ********************************************************************** ;;; ;;; Written by Bill Chiles and Rob Maclachlan. @@ -14,7 +17,7 @@ ;;; checking/correcting stuff in Spell-Corr.Lisp and the dictionary ;;; augmenting stuff in Spell-Augment.Lisp. -(in-package 'hemlock) +(in-package "HEMLOCK") @@ -25,7 +28,9 @@ (defun print-spell-info (obj str n) (declare (ignore n)) - (format str "#<Spell Info ~S>" (namestring (spell-info-pathname obj)))) + (let ((pn (spell-info-pathname obj))) + (format str "#<Spell Info~@[ ~S~]>" + (and pn (namestring pn))))) (defattribute "Spell Word Character" @@ -641,7 +646,7 @@ (name (spell-info-pathname info))) (when (spell-info-insertions info) (with-open-file (stream name - :direction :output :element-type 'string-char + :direction :output :element-type 'base-char :if-exists :append :if-does-not-exist :create) (dolist (w (spell-info-insertions info)) (write-line w stream))) diff --git a/hemlock/streams.lisp b/hemlock/streams.lisp index 0cfea3093..2893680dc 100644 --- a/hemlock/streams.lisp +++ b/hemlock/streams.lisp @@ -1,11 +1,14 @@ ;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- ;;; ;;; ********************************************************************** -;;; This code was written as part of the Spice Lisp project at -;;; Carnegie-Mellon University, and has been placed in the public domain. -;;; Spice Lisp is currently incomplete and under active development. -;;; If you want to use this code or any part of Spice Lisp, please contact -;;; Scott Fahlman (FAHLMAN@CMUC). +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/streams.lisp,v 1.3 1994/02/11 21:53:56 ram Exp $") +;;; ;;; ********************************************************************** ;;; ;;; This file contains definitions of various types of streams used @@ -124,13 +127,12 @@ ((:finish-output :force-output) (redisplay-windows-from-mark (hemlock-output-stream-mark stream))) (:close (setf (hemlock-output-stream-mark stream) nil)) - (:element-type 'string-char))) + (:element-type 'base-char))) (defstruct (hemlock-region-stream (:include stream (:in #'region-in) - (:misc #'region-misc) - (:in-buffer (make-string lisp::in-buffer-length))) + (:misc #'region-misc)) (:print-function %print-region-stream) (:constructor internal-make-hemlock-region-stream (region mark))) ;; @@ -151,8 +153,7 @@ region (copy-mark (region-start region) :right-inserting))) (defun modify-hemlock-region-stream (stream region) - (setf (hemlock-region-stream-region stream) region - (lisp::stream-in-index stream) lisp::in-buffer-length) + (setf (hemlock-region-stream-region stream) region) (let* ((mark (hemlock-region-stream-mark stream)) (start (region-start region)) (start-line (mark-line start))) @@ -162,102 +163,42 @@ (push mark (line-marks start-line))) stream) -(defun region-readline (stream eof-errorp eof-value) - (close-line) - (let ((mark (hemlock-region-stream-mark stream)) - (end (region-end (hemlock-region-stream-region stream)))) - (cond ((mark>= mark end) - (if eof-errorp - (error "~A hit end of file." stream) - (values eof-value nil))) - ((eq (mark-line mark) (mark-line end)) - (let* ((limit (mark-charpos end)) - (charpos (mark-charpos mark)) - (dst-end (- limit charpos)) - (result (make-string dst-end))) - (declare (simple-string result)) - (%sp-byte-blt (line-chars (mark-line mark)) charpos - result 0 dst-end) - (setf (mark-charpos mark) limit) - (values result t))) - ((= (mark-charpos mark) 0) - (let* ((line (mark-line mark)) - (next (line-next line))) - (always-change-line mark next) - (values (line-chars line) nil))) - (t - (let* ((line (mark-line mark)) - (chars (line-chars line)) - (next (line-next line)) - (charpos (mark-charpos mark)) - (dst-end (- (length chars) charpos)) - (result (make-string dst-end))) - (declare (simple-string chars result)) - (%sp-byte-blt chars charpos result 0 dst-end) - (setf (mark-charpos mark) 0) - (always-change-line mark next) - (values result nil)))))) - (defun region-in (stream eof-errorp eof-value) - (close-line) - (let* ((mark (hemlock-region-stream-mark stream)) - (charpos (mark-charpos mark)) - (line (mark-line mark)) - (chars (line-chars line)) - (length (length chars)) - (last (region-end (hemlock-region-stream-region stream))) - (last-line (mark-line last)) - (buffer (lisp::stream-in-buffer stream)) start len) - (declare (fixnum length charpos last-charpos start len) - (simple-string chars)) - (cond - ((eq line last-line) - (let ((last-charpos (mark-charpos last))) - (setq len (- last-charpos charpos)) - (cond - ((>= charpos last-charpos) - (if eof-errorp - (error "~A hit end of file." stream) - (return-from region-in eof-value))) - ((> len lisp::in-buffer-length) - (%sp-byte-blt chars charpos buffer 0 lisp::in-buffer-length) - (setq start 0 len lisp::in-buffer-length)) - (t - (setq start (- lisp::in-buffer-length len)) - (%sp-byte-blt chars charpos buffer start lisp::in-buffer-length))))) - ((line> line last-line) - (if eof-errorp - (error "~a hit end of file." stream) - (return-from region-in eof-value))) - (t - (setq len (- length charpos)) - (cond - ((< len lisp::in-buffer-length) - (let ((end (1- lisp::in-buffer-length))) - (setq start (- lisp::in-buffer-length len 1)) - (%sp-byte-blt chars charpos buffer start end) - (setf (schar buffer end) #\newline)) - (incf len)) - (t - (%sp-byte-blt chars charpos buffer 0 lisp::in-buffer-length) - (setq start 0 len lisp::in-buffer-length))))) - (setf (lisp::stream-in-index stream) (1+ start)) - (character-offset mark len) - (schar buffer start))) + (let ((mark (hemlock-region-stream-mark stream))) + (cond ((mark< mark + (region-end (hemlock-region-stream-region stream))) + (prog1 (next-character mark) (mark-after mark))) + (eof-errorp (error "~A hit end of file." stream)) + (t eof-value)))) (defun region-misc (stream operation &optional arg1 arg2) - (declare (ignore arg1 arg2)) + (declare (ignore arg2)) (case operation (:listen (mark< (hemlock-region-stream-mark stream) (region-end (hemlock-region-stream-region stream)))) - (:read-line (region-readline stream arg1 arg2)) (:clear-input (move-mark (hemlock-region-stream-mark stream) (region-end (hemlock-region-stream-region stream)))) + (:unread + (let ((mark (hemlock-region-stream-mark stream))) + (unless (mark> mark + (region-start (hemlock-region-stream-region stream))) + (error "Nothing to unread.")) + (unless (char= arg1 (previous-character mark)) + (error "Unreading something not read: ~S" arg1)) + (mark-before mark))) + (:file-position + (let ((start (region-start (hemlock-region-stream-region stream))) + (mark (hemlock-region-stream-mark stream))) + (cond (arg1 + (move-mark mark start) + (character-offset mark arg1)) + (t + (count-characters (region start mark)))))) (:close (delete-mark (hemlock-region-stream-mark stream)) (setf (hemlock-region-stream-region stream) nil)) - (:element-type 'string-char))) + (:element-type 'base-char))) ;;;; Stuff to support keyboard macros. diff --git a/hemlock/struct.lisp b/hemlock/struct.lisp index 6152c4a8a..c506ee540 100644 --- a/hemlock/struct.lisp +++ b/hemlock/struct.lisp @@ -1,11 +1,14 @@ ;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- ;;; ;;; ********************************************************************** -;;; This code was written as part of the Spice Lisp project at -;;; Carnegie-Mellon University, and has been placed in the public domain. -;;; Spice Lisp is currently incomplete and under active development. -;;; If you want to use this code or any part of Spice Lisp, please contact -;;; Scott Fahlman (FAHLMAN@CMUC). +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/struct.lisp,v 1.4 1994/02/11 21:53:57 ram Exp $") +;;; ;;; ********************************************************************** ;;; ;;; Structures and assorted macros for Hemlock. @@ -18,8 +21,8 @@ buffer-delete-hook buffer-windows buffer-variables buffer-write-date region regionp region-start region-end window windowp window-height window-width window-display-start window-display-end window-point - commandp command command-function command-documentation - modeline-field modeline-field-p)) + window-display-recentering commandp command command-function + command-documentation modeline-field modeline-field-p)) ;;;; Marks. @@ -57,8 +60,7 @@ font) (defmacro fast-font-mark-p (s) - `(eq (svref ,s 0) 'font-mark)) - + `(typep ,s 'font-mark)) ;;;; Regions, buffers, modeline fields. @@ -219,7 +221,9 @@ point ; Where the cursor is in this window. modeline-dis-line ; Dis-line for modeline display. modeline-buffer ; Complete string of all modeline data. - modeline-buffer-len) ; Valid chars in modeline-buffer. + modeline-buffer-len ; Valid chars in modeline-buffer. + display-recentering) ; Tells whether redisplay recenters window + ; regardless of whether it is current. (setf (documentation 'windowp 'function) "Returns true if its argument is a Hemlock window object, Nil otherwise.") @@ -229,16 +233,19 @@ "Return the width of a Hemlock window in character positions.") (setf (documentation 'window-display-start 'function) "Return the mark which points before the first character displayed in - the supplied window.") + the supplied window.") (setf (documentation 'window-display-end 'function) "Return the mark which points after the last character displayed in - the supplied window.") + the supplied window.") (setf (documentation 'window-point 'function) - "Return the mark that points to where the cursor is displayed in this - window. When the window is made current, the Buffer-Point of this - window's buffer is moved to this position. While the window is - current, redisplay makes this mark point to the same position as the - Buffer-Point of its buffer.") + "Return the mark that points to where the cursor is displayed in this + window. When the window is made current, the Buffer-Point of this window's + buffer is moved to this position. While the window is current, redisplay + makes this mark point to the same position as the Buffer-Point of its + buffer.") +(setf (documentation 'window-display-recentering 'function) + "This determines whether redisplay recenters window regardless of whether it + is current. This is SETF'able.") (defstruct (dis-line (:copier nil) (:constructor nil)) @@ -457,9 +464,11 @@ ; 0 sends digit-chars. (cm-y-pad nil) ; nil, 0, 2, or 3 for places to pad. ; 0 sends digit-chars. - screen-image) ; vector device-lines long of strings + screen-image ; vector device-lines long of strings ; device-columns long. - + ;; + ;; This terminal's baud rate, or NIL for infinite. + (speed nil :type (or (unsigned-byte 16) null))) ;;;; Device screen hunks and window-group. diff --git a/hemlock/syntax.lisp b/hemlock/syntax.lisp index fe69e9aad..cdfa7bb47 100644 --- a/hemlock/syntax.lisp +++ b/hemlock/syntax.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/syntax.lisp,v 1.1.1.4 1991/02/08 16:38:20 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/syntax.lisp,v 1.2 1994/02/11 21:53:59 ram Exp $") ;;; ;;; ********************************************************************** ;;; diff --git a/hemlock/table.lisp b/hemlock/table.lisp index a9643e796..2244f3660 100644 --- a/hemlock/table.lisp +++ b/hemlock/table.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/table.lisp,v 1.1.1.6 1993/08/25 02:10:57 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/table.lisp,v 1.2 1994/02/11 21:54:00 ram Exp $") ;;; ;;; ********************************************************************** ;;; diff --git a/hemlock/text.lisp b/hemlock/text.lisp index 83776da85..b8e1dba39 100644 --- a/hemlock/text.lisp +++ b/hemlock/text.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/text.lisp,v 1.1.1.3 1991/10/03 15:16:27 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/text.lisp,v 1.2 1994/02/11 21:54:02 ram Exp $") ;;; ;;; ********************************************************************** ;;; diff --git a/hemlock/ts-stream.lisp b/hemlock/ts-stream.lisp index d1e6644e1..f76498d72 100644 --- a/hemlock/ts-stream.lisp +++ b/hemlock/ts-stream.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/ts-stream.lisp,v 1.1.1.12 1993/08/30 21:48:47 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/ts-stream.lisp,v 1.2 1994/02/11 21:54:06 ram Exp $") ;;; ;;; ********************************************************************** ;;; diff --git a/hemlock/tty-disp-rt.lisp b/hemlock/tty-disp-rt.lisp index a2bc71402..8bb00b5bc 100644 --- a/hemlock/tty-disp-rt.lisp +++ b/hemlock/tty-disp-rt.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/tty-disp-rt.lisp,v 1.1.1.6 1992/02/15 01:06:24 wlott Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/tty-disp-rt.lisp,v 1.2 1994/02/11 21:54:07 ram Exp $") ;;; ;;; ********************************************************************** ;;; diff --git a/hemlock/tty-display.lisp b/hemlock/tty-display.lisp index f555e2d16..d288d0b73 100644 --- a/hemlock/tty-display.lisp +++ b/hemlock/tty-display.lisp @@ -1,11 +1,14 @@ ;;; -*- Log: hemlock.log; Package: Hemlock-Internals -*- ;;; ;;; ********************************************************************** -;;; This code was written as part of the Spice Lisp project at -;;; Carnegie-Mellon University, and has been placed in the public domain. -;;; Spice Lisp is currently incomplete and under active development. -;;; If you want to use this code or any part of Spice Lisp, please contact -;;; Scott Fahlman (FAHLMAN@CMUC). +;;; This code was written as part of the CMU Common Lisp project at +;;; Carnegie Mellon University, and has been placed in the public domain. +;;; If you want to use this code or any part of CMU Common Lisp, please contact +;;; Scott Fahlman or slisp-group@cs.cmu.edu. +;;; +(ext:file-comment + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/tty-display.lisp,v 1.3 1994/02/11 21:54:09 ram Exp $") +;;; ;;; ********************************************************************** ;;; ;;; Written by Bill Chiles. @@ -13,7 +16,7 @@ (in-package "HEMLOCK-INTERNALS") -(export '(redisplay redisplay-all)) +(export '(redisplay redisplay-all define-tty-font)) @@ -48,8 +51,9 @@ ;;; (defstruct (si-line (:print-function print-screen-image-line) (:constructor %make-si-line (chars))) - chars - (length 0)) + (chars nil :type simple-string) + (length 0) + (fonts nil :type list)) (defun make-si-line (n) (%make-si-line (make-string n))) @@ -61,22 +65,159 @@ (write-string "\">" str)) +(defun find-identical-prefix (dis-line dis-line-fonts si-line) + (declare (type dis-line dis-line) + (type list dis-line-fonts) + (type si-line si-line)) + (let* ((dl-chars (dis-line-chars dis-line)) + (dl-len (dis-line-length dis-line)) + (si-chars (si-line-chars si-line)) + (si-len (si-line-length si-line)) + (okay-until 0)) + (declare (type simple-string dl-chars si-chars) + (type (and unsigned-byte fixnum) dl-len si-len) + (type (and unsigned-byte fixnum) okay-until)) + (do ((dl-fonts dis-line-fonts (cdr dis-line-fonts)) + (si-fonts (si-line-fonts si-line) (cdr si-fonts))) + ((or (null dl-fonts) (null si-fonts)) + (let ((next-font (car (or dl-fonts si-fonts)))) + (if next-font + (let ((end (min dl-len si-len (cadr next-font)))) + (or (string/= dl-chars si-chars + :start1 okay-until :start2 okay-until + :end1 end :end2 end) + end)) + (let ((end (min dl-len si-len))) + (or (string/= dl-chars si-chars + :start1 okay-until :start2 okay-until + :end1 end :end2 end) + (if (= dl-len si-len) nil end)))))) + (let ((dl-font (caar dl-fonts)) + (dl-start (cadar dl-fonts)) + (dl-stop (cddar dl-fonts)) + (si-font (caar si-fonts)) + (si-start (cadar si-fonts)) + (si-stop (cddar si-fonts))) + (unless (and (= dl-font si-font) + (= dl-start si-start)) + (let ((font-lossage (min dl-start si-start))) + (return (or (string/= dl-chars si-chars + :start1 okay-until :start2 okay-until + :end1 font-lossage :end2 font-lossage) + font-lossage)))) + (unless (= dl-stop si-stop) + (let ((font-lossage (min dl-stop si-stop))) + (return (or (string/= dl-chars si-chars + :start1 okay-until :start2 okay-until + :end1 font-lossage :end2 font-lossage) + font-lossage)))) + (let ((mismatch (string/= dl-chars si-chars + :start1 okay-until :start2 okay-until + :end1 dl-stop :end2 si-stop))) + (if mismatch + (return mismatch) + (setf okay-until dl-stop))))))) + + +(defun find-identical-suffix (dis-line dis-line-fonts si-line) + (declare (type dis-line dis-line) + (type list dis-line-fonts) + (type si-line si-line)) + (let* ((dl-chars (dis-line-chars dis-line)) + (dl-len (dis-line-length dis-line)) + (si-chars (si-line-chars si-line)) + (si-len (si-line-length si-line)) + (count (dotimes (i (min dl-len si-len) i) + (when (char/= (schar dl-chars (- dl-len i 1)) + (schar si-chars (- si-len i 1))) + (return i))))) + (declare (type simple-string dl-chars si-chars) + (type (and unsigned-byte fixnum) dl-len si-len)) + (do ((dl-fonts (reverse dis-line-fonts) (cdr dis-line-fonts)) + (si-fonts (reverse (si-line-fonts si-line)) (cdr si-fonts))) + ((or (null dl-fonts) (null si-fonts)) + (cond (dl-fonts + (min (- dl-len (cddar dl-fonts)) count)) + (si-fonts + (min (- si-len (cddar si-fonts)) count)) + (t + count))) + (let ((dl-font (caar dl-fonts)) + (dl-start (- dl-len (cadar dl-fonts))) + (dl-stop (- dl-len (cddar dl-fonts))) + (si-font (caar si-fonts)) + (si-start (- si-len (cadar si-fonts))) + (si-stop (- si-len (cddar si-fonts)))) + (unless (and (= dl-font si-font) + (= dl-stop si-stop)) + (return (min dl-stop si-stop count))) + (unless (= dl-start si-start) + (return (min dl-start si-start count))) + (when (<= count dl-start) + (return count)))))) + + (defmacro si-line (screen-image n) `(svref ,screen-image ,n)) + +;;; Font support. + +(defvar *tty-font-strings* (make-array font-map-size :initial-element nil) + "Array of (start-string . end-string) for fonts, or NIL if no such font.") + +(defun define-tty-font (font-id &rest stuff) + (unless (<= 0 font-id (1- font-map-size)) + (error "Bogus font-id: ~S" font-id)) + (cond ((every #'keywordp stuff) + (error "Can't extract font strings from the termcap entry yet.")) + ((and (= (length stuff) 2) + (stringp (car stuff)) + (stringp (cadr stuff))) + (setf (aref *tty-font-strings* font-id) + (cons (car stuff) (cadr stuff)))) + (t + (error "Bogus font spec: ~S~%Must be either a list of keywords or ~ + a list of the start string and end string.")))) + + +(defun compute-font-usages (dis-line) + (do ((results nil) + (change (dis-line-font-changes dis-line) (font-change-next change)) + (prev nil change)) + ((null change) + (when prev + (let ((font (font-change-font prev))) + (when (and (not (zerop font)) + (aref *tty-font-strings* font)) + (push (list* (font-change-font prev) + (font-change-x prev) + (dis-line-length dis-line)) + results)))) + (nreverse results)) + (when prev + (let ((font (font-change-font prev))) + (when (and (not (zerop font)) + (aref *tty-font-strings* font)) + (push (list* (font-change-font prev) + (font-change-x prev) + (font-change-x change)) + results)))))) + ;;;; Dumb window redisplay. (defmacro tty-dumb-line-redisplay (device hunk dis-line &optional y) - (let ((dl (gensym)) (dl-chars (gensym)) (dl-len (gensym)) + (let ((dl (gensym)) (dl-chars (gensym)) (dl-fonts (gensym)) (dl-len (gensym)) (dl-pos (gensym)) (screen-image-line (gensym))) `(let* ((,dl ,dis-line) (,dl-chars (dis-line-chars ,dl)) + (,dl-fonts (compute-font-usages ,dis-line)) (,dl-len (dis-line-length ,dl)) (,dl-pos ,(or y `(dis-line-position ,dl)))) (funcall (tty-device-display-string ,device) - ,hunk 0 ,dl-pos ,dl-chars 0 ,dl-len) + ,hunk 0 ,dl-pos ,dl-chars ,dl-fonts 0 ,dl-len) (setf (dis-line-flags ,dl) unaltered-bits) (setf (dis-line-delta ,dl) 0) (select-hunk ,hunk) @@ -84,7 +225,8 @@ (+ *hunk-top-line* ,dl-pos)))) (replace-si-line (si-line-chars ,screen-image-line) ,dl-chars 0 0 ,dl-len) - (setf (si-line-length ,screen-image-line) ,dl-len))))) + (setf (si-line-length ,screen-image-line) ,dl-len) + (setf (si-line-fonts ,screen-image-line) ,dl-fonts))))) (defun tty-dumb-window-redisplay (window) (let* ((first (window-first-line window)) @@ -101,17 +243,21 @@ (i (+ *hunk-top-line* i) (1+ i))) ((> i last)) (declare (fixnum i last)) - (setf (si-line-length (si-line screen-image i)) 0))) + (let ((si-line (si-line screen-image i))) + (setf (si-line-length si-line) 0) + (setf (si-line-fonts si-line) nil)))) (tty-dumb-line-redisplay device hunk (car dl) i)) (setf (window-first-changed window) the-sentinel (window-last-changed window) first) (when (window-modeline-buffer window) (let ((dl (window-modeline-dis-line window)) (y (tty-hunk-modeline-pos hunk))) - (funcall (tty-device-standout-init device) hunk) - (funcall (tty-device-clear-to-eol device) hunk 0 y) - (tty-dumb-line-redisplay device hunk dl y) - (funcall (tty-device-standout-end device) hunk) + (unwind-protect + (progn + (funcall (tty-device-standout-init device) hunk) + (funcall (tty-device-clear-to-eol device) hunk 0 y) + (tty-dumb-line-redisplay device hunk dl y)) + (funcall (tty-device-standout-end device) hunk)) (setf (dis-line-flags dl) unaltered-bits))))) @@ -155,7 +301,7 @@ ;; ;; Clear any extra lines at the end of the window. (let ((pos (dis-line-position (car (window-last-line window))))) - (when (< pos (window-old-lines window)) + (when (< pos (1- (window-height window))) (tty-smart-clear-to-eow hunk (1+ pos))) (setf (window-old-lines window) pos)) ;; @@ -163,10 +309,11 @@ (when (window-modeline-buffer window) (let ((dl (window-modeline-dis-line window))) (when (/= (dis-line-flags dl) unaltered-bits) - (funcall (tty-device-standout-init device) hunk) (unwind-protect - (tty-smart-line-redisplay device hunk dl - (tty-hunk-modeline-pos hunk)) + (progn + (funcall (tty-device-standout-init device) hunk) + (tty-smart-line-redisplay device hunk dl + (tty-hunk-modeline-pos hunk))) (funcall (tty-device-standout-end device) hunk))))))) ;;; NEXT-DIS-LINE is used in DO-SEMI-DUMB-LINE-WRITES and @@ -193,7 +340,6 @@ (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 @@ -217,7 +363,8 @@ &optional (dl-pos (dis-line-position dl))) (declare (fixnum dl-pos)) (let* ((dl-chars (dis-line-chars dl)) - (dl-len (dis-line-length dl))) + (dl-len (dis-line-length dl)) + (dl-fonts (compute-font-usages dl))) (declare (fixnum dl-len) (simple-string dl-chars)) (when (listen-editor-input *editor-input*) (throw 'redisplay-catcher :editor-input)) @@ -226,9 +373,8 @@ (+ *hunk-top-line* dl-pos))) (si-line-chars (si-line-chars screen-image-line)) (si-line-length (si-line-length screen-image-line)) - (findex (string/= dl-chars si-line-chars - :end1 dl-len :end2 si-line-length))) - (declare (fixnum findex) (simple-string si-line-chars)) + (findex (find-identical-prefix dl dl-fonts screen-image-line))) + (declare (type (or fixnum null) findex) (simple-string si-line-chars)) ;; ;; When the dis-line and screen chars are not string=. (when findex @@ -236,18 +382,19 @@ ;; See if the screen shows an initial substring of the dis-line. ((= findex si-line-length) (funcall (tty-device-display-string device) - hunk findex dl-pos dl-chars findex dl-len) + hunk findex dl-pos dl-chars dl-fonts findex dl-len) (replace-si-line si-line-chars dl-chars findex findex dl-len)) ;; When the dis-line is an initial substring of what's on the screen. ((= findex dl-len) (funcall (tty-device-clear-to-eol device) hunk dl-len dl-pos)) ;; Otherwise, blast dl-chars and clear to eol as necessary. (t (funcall (tty-device-display-string device) - hunk findex dl-pos dl-chars findex dl-len) + hunk findex dl-pos dl-chars dl-fonts findex dl-len) (when (< dl-len si-line-length) (funcall (tty-device-clear-to-eol device) hunk dl-len dl-pos)) (replace-si-line si-line-chars dl-chars findex findex dl-len))) - (setf (si-line-length screen-image-line) dl-len))) + (setf (si-line-length screen-image-line) dl-len) + (setf (si-line-fonts screen-image-line) dl-fonts))) (setf (dis-line-flags dl) unaltered-bits) (setf (dis-line-delta dl) 0))) @@ -268,6 +415,8 @@ (defvar *tty-line-writes* (make-array tty-hunk-height-limit)) +(defvar *tty-line-moves* (make-array tty-hunk-height-limit)) + (eval-when (compile eval) (defmacro queue (value queue ptr) @@ -368,6 +517,7 @@ (declare (fixnum ,insert-index ,free-lines-index ,n)) (let ((,temp (si-line *screen-image-temp* ,free-lines-index))) (setf (si-line-length ,temp) 0) + (setf (si-line-fonts ,temp) nil) (setf (si-line ,do-screen-image ,insert-index) ,temp))) (decf ,fsil ,num)) (declare (fixnum ,target-terminus ,source-index ,target-index)) @@ -399,7 +549,7 @@ ;; One line-changed. (tty-smart-line-redisplay device hunk (car first-changed)) ;; More lines changed. - (multiple-value-bind (ins outs writes) + (multiple-value-bind (ins outs writes moves) (compute-tty-changes first-changed last-changed (tty-hunk-modeline-pos hunk)) @@ -413,6 +563,7 @@ (t (do-line-insertions hunk ins (do-line-deletions hunk outs)) + (note-line-moves moves) (do-line-writes hunk writes)))))) ;; Set the bounds so we know we displayed... (setf (window-first-changed window) the-sentinel @@ -420,7 +571,7 @@ ;; ;; Clear any extra lines at the end of the window. (let ((pos (dis-line-position (car (window-last-line window))))) - (when (< pos (window-old-lines window)) + (when (< pos (1- (window-height window))) (tty-smart-clear-to-eow hunk (1+ pos))) (setf (window-old-lines window) pos)) ;; @@ -428,10 +579,11 @@ (when (window-modeline-buffer window) (let ((dl (window-modeline-dis-line window))) (when (/= (dis-line-flags dl) unaltered-bits) - (funcall (tty-device-standout-init device) hunk) (unwind-protect - (tty-smart-line-redisplay device hunk dl - (tty-hunk-modeline-pos hunk)) + (progn + (funcall (tty-device-standout-init device) hunk) + (tty-smart-line-redisplay device hunk dl + (tty-hunk-modeline-pos hunk))) (funcall (tty-device-standout-end device) hunk))))))) @@ -533,10 +685,11 @@ ;;; done to the screen, we save the changed bit on, so the line will be ;;; queued to be written after redisplay is re-entered. ;;; -;;; If the line is changed or new, then queue it to be written. Note -;;; before that we checked the flags for equality with the new bits, and -;;; it is possible that updating the window image will yield lines that -;;; are both new and changed. +;;; If the line is changed or new, then queue it to be written. Since we can +;;; abort out of the actual dislpay at any time (due to pending input), we +;;; don't clear the flags or delta here. A dis-line may be groveled many times +;;; by this function before it actually makes it to the screen, so we may have +;;; odd combinations of bits such as both new and changed. ;;; ;;; Otherwise, get the next display line, loop, and see if it's ;;; interesting. @@ -545,68 +698,63 @@ (declare (fixnum modeline-pos)) (let* ((dl first-changed) (flags (dis-line-flags (car dl))) - (ins 0) (outs 0) (writes 0) + (ins 0) (outs 0) (writes 0) (moves 0) (prev-delta 0) (cum-deletes 0) (net-delta 0) (cum-inserts 0) prev) - (declare (fixnum flags ins outs writes prev-delta cum-deletes net-delta - cum-inserts)) + (declare (fixnum flags ins outs writes moves prev-delta cum-deletes + net-delta cum-inserts)) (loop - (cond - ((= flags new-bit) - (queue (car dl) *tty-line-writes* writes) - (next-dis-line)) - ((not (zerop (the fixnum (logand flags moved-bit)))) - (let* ((start-dl (car dl)) - (start-pos (dis-line-position start-dl)) - (curr-delta (dis-line-delta start-dl)) - (delta-delta (- prev-delta curr-delta)) - (car-dl start-dl)) - (declare (fixnum start-pos curr-delta delta-delta)) - (cond ((plusp delta-delta) - (queue (the fixnum (- start-pos cum-inserts)) - *tty-line-deletions* outs) - (queue delta-delta *tty-line-deletions* outs) - (incf cum-deletes delta-delta) - (decf net-delta delta-delta)) - ((minusp delta-delta) - (let ((eff-pos (the fixnum (+ start-pos delta-delta))) - (num (the fixnum (- delta-delta)))) - (queue eff-pos *tty-line-insertions* ins) - (queue num *tty-line-insertions* ins) - (incf net-delta num) - (incf cum-inserts num))) - (t (error "Internal error -- unexpected zero transition delta ~ - in redisplay."))) - (loop - (cond ((and (zerop (the fixnum (logand flags changed-bit))) - (zerop (the fixnum (logand flags new-bit)))) - (setf (dis-line-flags car-dl) unaltered-bits)) - (t (queue car-dl *tty-line-writes* writes) - ;; keep just the changed-bit on. - (setf (dis-line-flags car-dl) changed-bit))) - (setf (dis-line-delta car-dl) 0) - (next-dis-line) - (setf car-dl (car dl)) - (when (/= (the fixnum (dis-line-delta car-dl)) curr-delta) - (setf prev-delta curr-delta) - (return))))) - ((not (and (zerop (logand (the fixnum flags) changed-bit)) - (zerop (logand (the fixnum flags) new-bit)))) - (queue (car dl) *tty-line-writes* writes) - (next-dis-line)) - (t (next-dis-line))) - (when (eq prev last-changed) - (unless (zerop net-delta) - (cond ((plusp net-delta) - (queue (the fixnum (- modeline-pos cum-deletes net-delta)) - *tty-line-deletions* outs) - (queue net-delta *tty-line-deletions* outs)) - (t (queue (the fixnum (+ modeline-pos net-delta)) - *tty-line-insertions* ins) - (queue (the fixnum (- net-delta)) - *tty-line-insertions* ins)))) - (return (values ins outs writes)))))) - + (cond + ((logtest flags new-bit) + (queue (car dl) *tty-line-writes* writes) + (next-dis-line)) + ((logtest flags moved-bit) + (let* ((start-dl (car dl)) + (start-pos (dis-line-position start-dl)) + (curr-delta (dis-line-delta start-dl)) + (delta-delta (- prev-delta curr-delta)) + (car-dl start-dl)) + (declare (fixnum start-pos curr-delta delta-delta)) + (cond ((plusp delta-delta) + (queue (the fixnum (- start-pos cum-inserts)) + *tty-line-deletions* outs) + (queue delta-delta *tty-line-deletions* outs) + (incf cum-deletes delta-delta) + (decf net-delta delta-delta)) + ((minusp delta-delta) + (let ((eff-pos (the fixnum (+ start-pos delta-delta))) + (num (the fixnum (- delta-delta)))) + (queue eff-pos *tty-line-insertions* ins) + (queue num *tty-line-insertions* ins) + (incf net-delta num) + (incf cum-inserts num)))) + (loop + (if (logtest flags (logior changed-bit new-bit)) + (queue car-dl *tty-line-writes* writes) + (queue car-dl *tty-line-moves* moves)) + (next-dis-line) + (setf car-dl (car dl)) + (when (or (eq prev last-changed) + (/= (the fixnum (dis-line-delta car-dl)) curr-delta)) + (setf prev-delta curr-delta) + (return))))) + ((logtest flags (logior changed-bit new-bit)) + (queue (car dl) *tty-line-writes* writes) + (next-dis-line)) + (t + (next-dis-line))) + + (when (eq prev last-changed) + (unless (zerop net-delta) + (cond ((plusp net-delta) + (queue (the fixnum (- modeline-pos cum-deletes net-delta)) + *tty-line-deletions* outs) + (queue net-delta *tty-line-deletions* outs)) + (t (queue (the fixnum (+ modeline-pos net-delta)) + *tty-line-insertions* ins) + (queue (the fixnum (- net-delta)) + *tty-line-insertions* ins)))) + (return (values ins outs writes moves)))))) ;;;; Smart window redisplay -- operation methods. @@ -628,7 +776,20 @@ (let ((si-line (si-line screen-image si-idx))) (unless (zerop (si-line-length si-line)) (funcall clear-to-eol hunk 0 y) - (setf (si-line-length si-line) 0)))))) + (setf (si-line-length si-line) 0) + (setf (si-line-fonts si-line) nil)))))) + +;;; NOTE-LINE-MOVES -- Internal +;;; +;;; Clear out the flags and delta of lines that have been moved. +;;; +(defun note-line-moves (moves) + (let ((i 0)) + (loop + (when (= i moves) (return)) + (let ((dl (dequeue *tty-line-moves* i))) + (setf (dis-line-flags dl) unaltered-bits) + (setf (dis-line-delta dl) 0))))) ;;; DO-LINE-DELETIONS pops elements off the *tty-lines-deletions* queue, ;;; deleting lines from hunk's area of the screen. The internal screen @@ -711,7 +872,8 @@ &optional (dl-pos (dis-line-position dl))) (declare (fixnum dl-pos)) (let* ((dl-chars (dis-line-chars dl)) - (dl-len (dis-line-length dl))) + (dl-len (dis-line-length dl)) + (dl-fonts (compute-font-usages dl))) (declare (fixnum dl-len) (simple-string dl-chars)) (when (listen-editor-input *editor-input*) (throw 'redisplay-catcher :editor-input)) @@ -720,9 +882,8 @@ (+ *hunk-top-line* dl-pos))) (si-line-chars (si-line-chars screen-image-line)) (si-line-length (si-line-length screen-image-line)) - (findex (string/= dl-chars si-line-chars - :end1 dl-len :end2 si-line-length))) - (declare (fixnum findex) (simple-string si-line-chars)) + (findex (find-identical-prefix dl dl-fonts screen-image-line))) + (declare (type (or fixnum null) findex) (simple-string si-line-chars)) ;; ;; When the dis-line and screen chars are not string=. (when findex @@ -731,7 +892,7 @@ ;; See if the screen shows an initial substring of the dis-line. (when (= findex si-line-length) (funcall (tty-device-display-string device) - hunk findex dl-pos dl-chars findex dl-len) + hunk findex dl-pos dl-chars dl-fonts findex dl-len) (replace-si-line si-line-chars dl-chars findex findex dl-len) (return-from tslr-main-body t)) ;; @@ -741,20 +902,18 @@ (return-from tslr-main-body t)) ;; ;; Find trailing substrings that are the same. - (multiple-value-bind (sindex dindex) - (do ((sindex (1- si-line-length) (1- sindex)) - (dindex (1- dl-len) (1- dindex))) - ((or (= sindex -1) - (= dindex -1) - (char/= (schar dl-chars dindex) - (schar si-line-chars sindex))) - (values (1+ sindex) (1+ dindex)))) + (multiple-value-bind + (sindex dindex) + (let ((count (find-identical-suffix dl dl-fonts + screen-image-line))) + (values (- si-line-length count) + (- dl-len count))) (declare (fixnum sindex dindex)) ;; ;; No trailing substrings -- blast and clear to eol. (when (= dindex dl-len) (funcall (tty-device-display-string device) - hunk findex dl-pos dl-chars findex dl-len) + hunk findex dl-pos dl-chars dl-fonts findex dl-len) (when (< dindex sindex) (funcall (tty-device-clear-to-eol device) hunk dl-len dl-pos)) @@ -766,7 +925,8 @@ (setf lindex findex)) (t (funcall (tty-device-display-string device) - hunk findex dl-pos dl-chars findex lindex) + hunk findex dl-pos dl-chars dl-fonts + findex lindex) (replace-si-line si-line-chars dl-chars findex findex lindex))) (cond @@ -780,19 +940,23 @@ hunk dindex dl-pos delete-char-num)) (t (funcall (tty-device-display-string device) - hunk dindex dl-pos dl-chars dindex dl-len) + hunk dindex dl-pos dl-chars dl-fonts + dindex dl-len) (funcall (tty-device-clear-to-eol device) hunk dl-len dl-pos))))) (t (if (and (tty-device-insert-string device) - (worth-using-insert-mode device (- dindex sindex))) + (worth-using-insert-mode device (- dindex sindex) + (- dl-len sindex))) (funcall (tty-device-insert-string device) hunk sindex dl-pos dl-chars sindex dindex) (funcall (tty-device-display-string device) - hunk sindex dl-pos dl-chars sindex dl-len)))) + hunk sindex dl-pos dl-chars dl-fonts + sindex dl-len)))) (replace-si-line si-line-chars dl-chars lindex lindex dl-len)))) - (setf (si-line-length screen-image-line) dl-len))) + (setf (si-line-length screen-image-line) dl-len) + (setf (si-line-fonts screen-image-line) dl-fonts))) (setf (dis-line-flags dl) unaltered-bits) (setf (dis-line-delta dl) 0))) @@ -908,11 +1072,36 @@ ;;; DISPLAY-STRING is used to put a string at (x,y) on the device. ;;; -(defun display-string (hunk x y string +(defun display-string (hunk x y string font-info &optional (start 0) (end (strlen string))) (declare (fixnum x y start end)) (update-cursor hunk x y) - (device-write-string string start end) + ;; Ignore font info for chars before the start of the string. + (loop + (if (or (null font-info) + (< start (cddar font-info))) + (return) + (pop font-info))) + (let ((posn start)) + (dolist (next-font font-info) + (let ((font (car next-font)) + (start (cadr next-font)) + (stop (cddr next-font))) + (when (<= end start) + (return)) + (when (< posn start) + (device-write-string string posn start) + (setf posn start)) + (let ((new-posn (min stop end)) + (font-strings (aref *tty-font-strings* font))) + (unwind-protect + (progn + (device-write-string (car font-strings)) + (device-write-string string posn new-posn)) + (device-write-string (cdr font-strings))) + (setf posn new-posn)))) + (when (< posn end) + (device-write-string string posn end))) (setf (tty-device-cursor-x (device-hunk-device hunk)) (the fixnum (+ x (the fixnum (- end start)))))) @@ -922,16 +1111,17 @@ ;;; what the sequence is), whether the terminal has insert-mode, or whether ;;; the terminal has delete-mode. ;;; -(defun display-string-checking-underlines (hunk x y string +(defun display-string-checking-underlines (hunk x y string font-info &optional (start 0) (end (strlen string))) + (declare (ignore font-info)) (declare (fixnum x y start end) (simple-string string)) (update-cursor hunk x y) (let ((upos (position #\_ string :test #'char= :start start :end end)) (device (device-hunk-device hunk))) (if upos (let ((previous start) - after-pos) + (after-pos 0)) (declare (fixnum previous after-pos)) (loop (device-write-string string previous upos) (setf after-pos (do ((i (1+ upos) (1+ i))) @@ -1026,25 +1216,25 @@ (let* ((device (device-hunk-device hunk)) (init-string (tty-device-insert-init-string device)) (char-init-string (tty-device-insert-char-init-string device)) - (cis-len (if char-init-string (length char-init-string))) (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 (simple-string char-init-string char-end-string)) + (declare (type (or simple-string null) char-init-string char-end-string)) (when init-string (device-write-string init-string)) (if char-init-string - (do ((i start (1+ i))) - ((= i end)) - (device-write-string char-init-string 0 cis-len) - (tty-write-char (schar string i)) - (when char-end-string - (device-write-string char-end-string 0 ces-len))) + (let ((cis-len (length char-init-string)) + (ces-len (length char-end-string))) + (do ((i start (1+ i))) + ((= i end)) + (device-write-string char-init-string 0 cis-len) + (tty-write-char (schar string i)) + (when char-end-string + (device-write-string char-end-string 0 ces-len)))) (device-write-string string start end)) (when end-string (device-write-string end-string)) (setf (tty-device-cursor-x device) (the fixnum (+ x (the fixnum (- end start))))))) -(defun worth-using-insert-mode (device insert-char-num) +(defun worth-using-insert-mode (device insert-char-num chars-saved) (let* ((init-string (tty-device-insert-init-string device)) (char-init-string (tty-device-insert-char-init-string device)) (char-end-string (tty-device-insert-char-end-string device)) @@ -1059,9 +1249,9 @@ char-end-string)) 0))))) (when end-string (incf cost (length (the simple-string end-string)))) - (< cost insert-char-num))) + (< cost chars-saved))) -(defun delete-char (hunk x y &optional n) +(defun delete-char (hunk x y &optional (n 1)) (declare (fixnum x y n)) (update-cursor hunk x y) (let* ((device (device-hunk-device hunk)) @@ -1074,13 +1264,14 @@ (when end-string (device-write-string end-string)))) (defun worth-using-delete-mode (device delete-char-num clear-char-num) - (declare (fixnum num)) + (declare (fixnum delete-char-num clear-char-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 (simple-string init-string end-string delete-char-string) + (declare (type (or simple-string null) 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/hemlock/tty-stream.lisp b/hemlock/tty-stream.lisp index c4433ffcb..0feebdf19 100644 --- a/hemlock/tty-stream.lisp +++ b/hemlock/tty-stream.lisp @@ -7,7 +7,7 @@ ;;; Scott Fahlman or slisp-group@cs.cmu.edu. ;;; (ext:file-comment - "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/tty-stream.lisp,v 1.1.1.5 1993/08/25 02:24:03 ram Exp $") + "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/hemlock/tty-stream.lisp,v 1.2 1994/02/11 21:54:11 ram Exp $") ;;; ;;; ********************************************************************** ;;; -- GitLab