| 1 | ;;; -*- Log: hemlock.log; Package: Hemlock -*-
|
|---|
| 2 | ;;;
|
|---|
| 3 | ;;; **********************************************************************
|
|---|
| 4 | ;;; This code was written as part of the CMU Common Lisp project at
|
|---|
| 5 | ;;; Carnegie Mellon University, and has been placed in the public domain.
|
|---|
| 6 | ;;;
|
|---|
| 7 | #+CMU (ext:file-comment
|
|---|
| 8 | "$Header$")
|
|---|
| 9 | ;;;
|
|---|
| 10 | ;;; **********************************************************************
|
|---|
| 11 | ;;;
|
|---|
| 12 | ;;; Hemlock Word Abbreviation Mode
|
|---|
| 13 | ;;; by Jamie W. Zawinski
|
|---|
| 14 | ;;; 24 September 1985
|
|---|
| 15 | ;;;
|
|---|
| 16 | (in-package :hemlock)
|
|---|
| 17 |
|
|---|
| 18 | ;;;; These Things are Here:
|
|---|
| 19 |
|
|---|
| 20 | ;;; C-X C-A Add Mode Word Abbrev
|
|---|
| 21 | ;;; Define a mode abbrev for the word before point.
|
|---|
| 22 | ;;; C-X + Add Global Word Abbrev
|
|---|
| 23 | ;;; Define a global abbrev for the word before point.
|
|---|
| 24 | ;;; C-X C-H Inverse Add Mode Word Abbrev
|
|---|
| 25 | ;;; Define expansion for mode abbrev before point.
|
|---|
| 26 | ;;; C-X - Inverse Add Global Word Abbrev
|
|---|
| 27 | ;;; Define expansion for global abbrev before point.
|
|---|
| 28 | ;;; Alt Space Abbrev Expand Only
|
|---|
| 29 | ;;; Expand abbrev without inserting anything.
|
|---|
| 30 | ;;; M-' Word Abbrev Prefix Mark
|
|---|
| 31 | ;;; Mark a prefix to be glued to an abbrev following.
|
|---|
| 32 | ;;; C-X U Unexpand Last Word
|
|---|
| 33 | ;;; Unexpands last abbrev or undoes C-X U.
|
|---|
| 34 |
|
|---|
| 35 | ;;; List Word Abbrevs Shows definitions of all word abbrevs.
|
|---|
| 36 | ;;; Edit Word Abbrevs Lets you edit the definition list directly.
|
|---|
| 37 | ;;; Read Word Abbrev File <filename> Define word abbrevs from a definition file.
|
|---|
| 38 | ;;; Write Word Abbrev File Make a definition file from current abbrevs.
|
|---|
| 39 |
|
|---|
| 40 | ;;; Make Word Abbrev <abbrev><expansion><mode> More General form of C-X C-A, etc.
|
|---|
| 41 | ;;; Delete All Word Abbrevs Wipes them all.
|
|---|
| 42 | ;;; Delete Mode Word Abbrev Kills all Mode abbrev.
|
|---|
| 43 | ;;; Delete Global Word Abbrev Kills all Global abbrev.
|
|---|
| 44 |
|
|---|
| 45 | ;;; Insert Word Abbrevs Inserts a list of current definitions in the
|
|---|
| 46 | ;;; format that Define Word Abbrevs uses.
|
|---|
| 47 | ;;; Define Word Abbrevs Defines set of abbrevs from a definition list in
|
|---|
| 48 | ;;; the buffer.
|
|---|
| 49 | ;;; Word Abbrev Apropos <string> Shows definitions containing <string> in abbrev,
|
|---|
| 50 | ;;; definition, or mode.
|
|---|
| 51 |
|
|---|
| 52 | ;;; Append Incremental Word Abbrev File Appends to a file changed abbrev
|
|---|
| 53 | ;;; definitions since last dumping.
|
|---|
| 54 |
|
|---|
| 55 | (defmode "Abbrev" :major-p nil :transparent-p t :precedence 2.0)
|
|---|
| 56 |
|
|---|
| 57 |
|
|---|
| 58 | (defvar *global-abbrev-table* (make-hash-table :test #'equal)
|
|---|
| 59 | "Hash table holding global abbrev definitions.")
|
|---|
| 60 |
|
|---|
| 61 | (defhvar "Abbrev Pathname Defaults"
|
|---|
| 62 | "Holds the name of the last Abbrev-file written."
|
|---|
| 63 | :value (pathname "abbrev.defns"))
|
|---|
| 64 |
|
|---|
| 65 | (defvar *new-abbrevs* ()
|
|---|
| 66 | "holds a list of abbrevs (and their definitions and modes) changed since saving.")
|
|---|
| 67 |
|
|---|
| 68 | |
|---|
| 69 |
|
|---|
| 70 | ;;; C-X C-H Inverse Add Mode Word Abbrev
|
|---|
| 71 | ;;; Define a mode expansion for the word before point.
|
|---|
| 72 |
|
|---|
| 73 | (defcommand "Inverse Add Mode Word Abbrev" (p)
|
|---|
| 74 | "Defines a mode word abbrev expansion for the word before the point."
|
|---|
| 75 | "Defines a mode word abbrev expansion for the word before the point."
|
|---|
| 76 | (declare (ignore p))
|
|---|
| 77 | (let ((word (prev-word 1 (current-point)))
|
|---|
| 78 | (mode (buffer-major-mode (current-buffer))))
|
|---|
| 79 | (make-word-abbrev-command nil word nil mode)))
|
|---|
| 80 |
|
|---|
| 81 |
|
|---|
| 82 | ;;; C-X C-A Add Mode Word Abbrev
|
|---|
| 83 | ;;; Define mode abbrev for word before point.
|
|---|
| 84 |
|
|---|
| 85 | (defcommand "Add Mode Word Abbrev" (p)
|
|---|
| 86 | "Defines a mode word abbrev for the word before the point.
|
|---|
| 87 | With a positive argument, uses that many preceding words as the expansion.
|
|---|
| 88 | With a zero argument, uses the region as the expansion. With a negative
|
|---|
| 89 | argument, prompts for a word abbrev to delete in the current mode."
|
|---|
| 90 | "Defines or deletes a mode word abbrev."
|
|---|
| 91 | (if (and p (minusp p))
|
|---|
| 92 | (delete-mode-word-abbrev-command nil)
|
|---|
| 93 | (let* ((val (if (eql p 0)
|
|---|
| 94 | (region-to-string (current-region nil))
|
|---|
| 95 | (prev-word (or p 1) (current-point))))
|
|---|
| 96 | (mode (buffer-major-mode (current-buffer))))
|
|---|
| 97 | (make-word-abbrev-command nil nil val mode))))
|
|---|
| 98 |
|
|---|
| 99 |
|
|---|
| 100 |
|
|---|
| 101 | ;;; C-X - Inverse Add Global Word Abbrev
|
|---|
| 102 | ;;; Define global expansion for word before point.
|
|---|
| 103 |
|
|---|
| 104 | (defcommand "Inverse Add Global Word Abbrev" (p)
|
|---|
| 105 | "Defines a Global expansion for the word before point."
|
|---|
| 106 | "Defines a Global expansion for the word before point."
|
|---|
| 107 | (declare (ignore p))
|
|---|
| 108 | (let ((word (prev-word 1 (current-point))))
|
|---|
| 109 | (make-word-abbrev-command nil word nil "Global")))
|
|---|
| 110 |
|
|---|
| 111 |
|
|---|
| 112 |
|
|---|
| 113 | ;;; C-X + Add Global Word Abbrev
|
|---|
| 114 | ;;; Define global Abbrev for word before point.
|
|---|
| 115 |
|
|---|
| 116 | (defcommand "Add Global Word Abbrev" (p)
|
|---|
| 117 | "Defines a global word abbrev for the word before the point.
|
|---|
| 118 | With a positive argument, uses that many preceding words as the expansion.
|
|---|
| 119 | With a zero argument, uses the region as the expansion. With a negative
|
|---|
| 120 | argument, prompts for a global word abbrev to delete."
|
|---|
| 121 | "Defines or deletes a global word abbrev."
|
|---|
| 122 | (if (and p (minusp p))
|
|---|
| 123 | (delete-global-word-abbrev-command nil)
|
|---|
| 124 | (let ((val (if (eql p 0)
|
|---|
| 125 | (region-to-string (current-region nil))
|
|---|
| 126 | (prev-word (or p 1) (current-point)))))
|
|---|
| 127 | (make-word-abbrev-command nil nil val "Global"))))
|
|---|
| 128 |
|
|---|
| 129 | |
|---|
| 130 |
|
|---|
| 131 | ;;;; Defining Abbrevs
|
|---|
| 132 |
|
|---|
| 133 | ;;; Make Word Abbrev <abbrev><expansion><mode> More General form of C-X C-A, etc.
|
|---|
| 134 |
|
|---|
| 135 | (defvar *global-abbrev-string-table*
|
|---|
| 136 | (make-string-table :initial-contents '(("Global" . nil))))
|
|---|
| 137 |
|
|---|
| 138 | (defcommand "Make Word Abbrev" (p &optional abbrev expansion mode)
|
|---|
| 139 | "Defines an arbitrary word abbreviation.
|
|---|
| 140 | Prompts for abbrev, expansion, and mode."
|
|---|
| 141 | "Makes Abbrev be a word abbreviation for Expansion when in Mode. If
|
|---|
| 142 | mode is \"Global\" then make a global abbrev."
|
|---|
| 143 | (declare (ignore p))
|
|---|
| 144 | (unless mode
|
|---|
| 145 | (setq mode
|
|---|
| 146 | (prompt-for-keyword
|
|---|
| 147 | (list *mode-names* *global-abbrev-string-table*)
|
|---|
| 148 | :prompt "Mode of abbrev to add: "
|
|---|
| 149 | :default "Global"
|
|---|
| 150 | :help
|
|---|
| 151 | "Type the mode of the Abbrev you want to add, or confirm for Global.")))
|
|---|
| 152 | (let ((globalp (string-equal mode "Global")))
|
|---|
| 153 | (unless (or globalp (mode-major-p mode))
|
|---|
| 154 | (editor-error "~A is not a major mode." mode))
|
|---|
| 155 | (unless abbrev
|
|---|
| 156 | (setq abbrev
|
|---|
| 157 | (prompt-for-string
|
|---|
| 158 | :trim t
|
|---|
| 159 | :prompt
|
|---|
| 160 | (list "~A abbreviation~@[ of ~S~]: " mode expansion)
|
|---|
| 161 | :help
|
|---|
| 162 | (list "Define a ~A word abbrev." mode))))
|
|---|
| 163 | (when (zerop (length abbrev))
|
|---|
| 164 | (editor-error "Abbreviation must be at least one character long."))
|
|---|
| 165 | (unless (every #'(lambda (ch)
|
|---|
| 166 | (zerop (character-attribute :word-delimiter ch)))
|
|---|
| 167 | (the simple-string abbrev))
|
|---|
| 168 | (editor-error "Word Abbrevs must be a single word."))
|
|---|
| 169 | (unless expansion
|
|---|
| 170 | (setq expansion
|
|---|
| 171 | (prompt-for-string
|
|---|
| 172 | :prompt (list "~A expansion for ~S: " mode abbrev)
|
|---|
| 173 | :help (list "Define the ~A expansion of ~S." mode abbrev))))
|
|---|
| 174 | (setq abbrev (string-downcase abbrev))
|
|---|
| 175 | (let* ((table (cond (globalp *global-abbrev-table*)
|
|---|
| 176 | ((hemlock-bound-p 'Mode-Abbrev-Table :mode mode)
|
|---|
| 177 | (variable-value 'Mode-Abbrev-Table :mode mode))
|
|---|
| 178 | (t
|
|---|
| 179 | (let ((new (make-hash-table :test #'equal)))
|
|---|
| 180 | (defhvar "Mode Abbrev Table"
|
|---|
| 181 | "Hash Table of Mode Abbrevs"
|
|---|
| 182 | :value new :mode mode)
|
|---|
| 183 | new))))
|
|---|
| 184 | (old (gethash abbrev table)))
|
|---|
| 185 | (when (or (not old)
|
|---|
| 186 | (prompt-for-y-or-n
|
|---|
| 187 | :prompt
|
|---|
| 188 | (list "Current ~A definition of ~S is ~S.~%Redefine?"
|
|---|
| 189 | mode abbrev old)
|
|---|
| 190 | :default t
|
|---|
| 191 | :help (list "Redefine the expansion of ~S." abbrev)))
|
|---|
| 192 | (setf (gethash abbrev table) expansion)
|
|---|
| 193 | (push (list abbrev expansion (if globalp nil mode))
|
|---|
| 194 | *new-abbrevs*)))))
|
|---|
| 195 |
|
|---|
| 196 | |
|---|
| 197 |
|
|---|
| 198 | ;;; Alt Space Abbrev Expand Only
|
|---|
| 199 | ;;; Expand abbrev without inserting anything.
|
|---|
| 200 |
|
|---|
| 201 | (defcommand "Abbrev Expand Only" (p)
|
|---|
| 202 | "This command expands the word before point into its abbrev definition
|
|---|
| 203 | (if indeed it has one)."
|
|---|
| 204 | "This command expands the word before point into its abbrev definition
|
|---|
| 205 | (if indeed it has one)."
|
|---|
| 206 | (declare (ignore p))
|
|---|
| 207 | (let* ((word (prev-word 1 (current-point)))
|
|---|
| 208 | (glob (gethash (string-downcase word) *global-abbrev-table*))
|
|---|
| 209 | (mode (if (hemlock-bound-p 'Mode-Abbrev-Table)
|
|---|
| 210 | (gethash (string-downcase word)
|
|---|
| 211 | (value Mode-Abbrev-Table))))
|
|---|
| 212 | (end-word (reverse-find-attribute (copy-mark (current-point)
|
|---|
| 213 | :right-inserting)
|
|---|
| 214 | :word-delimiter #'zerop))
|
|---|
| 215 | (result (if mode mode glob)))
|
|---|
| 216 | (when (or mode glob)
|
|---|
| 217 | (delete-characters end-word (- (length word)))
|
|---|
| 218 | (cond ((equal word (string-capitalize word))
|
|---|
| 219 | (setq result (string-capitalize result)))
|
|---|
| 220 | ((equal word (string-upcase word))
|
|---|
| 221 | (setq result (string-upcase result))))
|
|---|
| 222 | (insert-string end-word result)
|
|---|
| 223 | (unless (hemlock-bound-p 'last-expanded)
|
|---|
| 224 | (defhvar "last expanded"
|
|---|
| 225 | "Holds a mark, the last expanded abbrev, and its expansion in a list."
|
|---|
| 226 | :buffer (current-buffer)))
|
|---|
| 227 | (setf (value last-expanded)
|
|---|
| 228 | (list (copy-mark (current-point) :right-inserting)
|
|---|
| 229 | word result)))
|
|---|
| 230 | (delete-mark end-word))
|
|---|
| 231 | (when (and (hemlock-bound-p 'prefix-mark)
|
|---|
| 232 | (value prefix-mark))
|
|---|
| 233 | (delete-characters (value prefix-mark) 1)
|
|---|
| 234 | (delete-mark (value prefix-mark))
|
|---|
| 235 | (setf (value prefix-mark) nil)))
|
|---|
| 236 |
|
|---|
| 237 |
|
|---|
| 238 |
|
|---|
| 239 | ;;; This function returns the n words immediately before the mark supplied.
|
|---|
| 240 |
|
|---|
| 241 | (defun prev-word (n mark)
|
|---|
| 242 | (let* ((mark-1 (reverse-find-attribute (copy-mark mark :temporary)
|
|---|
| 243 | :word-delimiter #'zerop))
|
|---|
| 244 | (mark-2 (copy-mark mark-1)))
|
|---|
| 245 | (dotimes (x n (region-to-string (region mark-2 mark-1)))
|
|---|
| 246 | (reverse-find-attribute (mark-before mark-2) :word-delimiter))))
|
|---|
| 247 |
|
|---|
| 248 |
|
|---|
| 249 |
|
|---|
| 250 | ;;; M-' Word Abbrev Prefix Mark
|
|---|
| 251 | ;;; Mark a prefix to be glued to an abbrev following.
|
|---|
| 252 |
|
|---|
| 253 | ;;; When "Abbrev Expand Only" expands the abbrev (because #\- is an expander)
|
|---|
| 254 | ;;; it will see that prefix-mark is non-nil, and will delete the #\- immediately
|
|---|
| 255 | ;;; after prefix-mark.
|
|---|
| 256 |
|
|---|
| 257 | (defcommand "Word Abbrev Prefix Mark" (p)
|
|---|
| 258 | "Marks a prefix to be glued to an abbrev following."
|
|---|
| 259 | "Marks a prefix to be glued to an abbrev following."
|
|---|
| 260 | (declare (ignore p))
|
|---|
| 261 | (unless (hemlock-bound-p 'prefix-mark)
|
|---|
| 262 | (defhvar "prefix mark"
|
|---|
| 263 | "Holds a mark (or not) pointing to the current Prefix Mark."
|
|---|
| 264 | :buffer (current-buffer)))
|
|---|
| 265 | (when (value prefix-mark)
|
|---|
| 266 | (delete-mark (value prefix-mark)))
|
|---|
| 267 | (setf (value prefix-mark) (copy-mark (current-point) :right-inserting))
|
|---|
| 268 | (insert-character (value prefix-mark) #\-))
|
|---|
| 269 |
|
|---|
| 270 | |
|---|
| 271 |
|
|---|
| 272 | ;;; C-X U Unexpand Last Word
|
|---|
| 273 | ;;; Unexpands last abbrev or undoes last C-X U.
|
|---|
| 274 |
|
|---|
| 275 | (defcommand "Unexpand Last Word" (p)
|
|---|
| 276 | "Undoes the last abbrev expansion, or undoes \"Unexpand Last Word\".
|
|---|
| 277 | Only one abbrev may be undone."
|
|---|
| 278 | "Undoes the last abbrev expansion, or undoes \"Unexpand Last Word\"."
|
|---|
| 279 | (declare (ignore p))
|
|---|
| 280 | (unless (or (not (hemlock-bound-p 'last-expanded))
|
|---|
| 281 | (value last-expanded))
|
|---|
| 282 | (editor-error "Nothing to Undo."))
|
|---|
| 283 | (let ((mark (car (value last-expanded)))
|
|---|
| 284 | (word1 (second (value last-expanded)))
|
|---|
| 285 | (word2 (third (value last-expanded))))
|
|---|
| 286 | (unless (string= word2
|
|---|
| 287 | (region-to-string
|
|---|
| 288 | (region (character-offset (copy-mark mark :temporary)
|
|---|
| 289 | (- (length word2)))
|
|---|
| 290 | mark)))
|
|---|
| 291 | (editor-error "The last expanded Abbrev has been altered in the text."))
|
|---|
| 292 | (delete-characters mark (- (length word2)))
|
|---|
| 293 | (insert-string mark word1)
|
|---|
| 294 | (character-offset mark (length word1))
|
|---|
| 295 | (setf (value last-expanded) (list mark word2 word1))))
|
|---|
| 296 |
|
|---|
| 297 |
|
|---|
| 298 |
|
|---|
| 299 | ;;; Delete Mode Word Abbrev Kills some Mode abbrevs.
|
|---|
| 300 |
|
|---|
| 301 | (defcommand "Delete Mode Word Abbrev"
|
|---|
| 302 | (p &optional abbrev
|
|---|
| 303 | (mode (buffer-major-mode (current-buffer))))
|
|---|
| 304 | "Prompts for a word abbrev and deletes the mode expansion in the current mode.
|
|---|
| 305 | If called with a prefix argument, deletes all word abbrevs define in the
|
|---|
| 306 | current mode."
|
|---|
| 307 | "Deletes Abbrev in Mode, or all abbrevs in Mode if P is true."
|
|---|
| 308 | (let ((boundp (hemlock-bound-p 'Mode-Abbrev-Table :mode mode)))
|
|---|
| 309 | (if p
|
|---|
| 310 | (when boundp
|
|---|
| 311 | (delete-variable 'Mode-Abbrev-Table :mode mode))
|
|---|
| 312 | (let ((down
|
|---|
| 313 | (string-downcase
|
|---|
| 314 | (or abbrev
|
|---|
| 315 | (prompt-for-string
|
|---|
| 316 | :prompt (list "~A abbrev to delete: " mode)
|
|---|
| 317 | :help
|
|---|
| 318 | (list "Give the name of a ~A mode word abbrev to delete." mode)
|
|---|
| 319 | :trim t))))
|
|---|
| 320 | (table (and boundp (variable-value 'mode-abbrev-table :mode mode))))
|
|---|
| 321 | (unless (and table (gethash down table))
|
|---|
| 322 | (editor-error "~S is not the name of an abbrev in ~A mode."
|
|---|
| 323 | down mode))
|
|---|
| 324 | (remhash down table)))))
|
|---|
| 325 |
|
|---|
| 326 |
|
|---|
| 327 | ;;; Delete Global Word Abbrevs Kills some Global abbrevs.
|
|---|
| 328 |
|
|---|
| 329 | (defcommand "Delete Global Word Abbrev" (p &optional abbrev)
|
|---|
| 330 | "Prompts for a word abbrev and delete the global expansion.
|
|---|
| 331 | If called with a prefix argument, deletes all global abbrevs."
|
|---|
| 332 | "Deletes the global word abbreviation named Abbrev. If P is true,
|
|---|
| 333 | deletes all global abbrevs."
|
|---|
| 334 | (if p
|
|---|
| 335 | (setq *global-abbrev-table* (make-hash-table :test #'equal))
|
|---|
| 336 | (let ((down
|
|---|
| 337 | (string-downcase
|
|---|
| 338 | (or abbrev
|
|---|
| 339 | (prompt-for-string
|
|---|
| 340 | :prompt "Global abbrev to delete: "
|
|---|
| 341 | :help "Give the name of a global word abbrev to delete."
|
|---|
| 342 | :trim t)))))
|
|---|
| 343 | (unless (gethash down *global-abbrev-table*)
|
|---|
| 344 | (editor-error "~S is not the name of a global word abbrev." down))
|
|---|
| 345 | (remhash down *global-abbrev-table*))))
|
|---|
| 346 |
|
|---|
| 347 | ;;; Delete All Word Abbrevs Wipes them all.
|
|---|
| 348 |
|
|---|
| 349 | (defcommand "Delete All Word Abbrevs" (p)
|
|---|
| 350 | "Deletes all currently defined Word Abbrevs"
|
|---|
| 351 | "Deletes all currently defined Word Abbrevs"
|
|---|
| 352 | (declare (ignore p))
|
|---|
| 353 | (Delete-Global-Word-Abbrev-Command 1)
|
|---|
| 354 | (Delete-Mode-Word-Abbrev-Command 1))
|
|---|
| 355 |
|
|---|
| 356 | |
|---|
| 357 |
|
|---|
| 358 | ;;;; Abbrev I/O
|
|---|
| 359 |
|
|---|
| 360 | ;;; List Word Abbrevs Shows definitions of all word abbrevs.
|
|---|
| 361 |
|
|---|
| 362 | (defcommand "List Word Abbrevs" (p)
|
|---|
| 363 | "Lists all of the currently defined Word Abbrevs."
|
|---|
| 364 | "Lists all of the currently defined Word Abbrevs."
|
|---|
| 365 | (word-abbrev-apropos-command p ""))
|
|---|
| 366 |
|
|---|
| 367 |
|
|---|
| 368 | ;;; Word Abbrev Apropos <string> Shows definitions containing <string> in abbrev,
|
|---|
| 369 | ;;; definition, or mode.
|
|---|
| 370 |
|
|---|
| 371 | (defcommand "Word Abbrev Apropos" (p &optional search-string)
|
|---|
| 372 | "Lists all of the currently defined Word Abbrevs which contain a given string
|
|---|
| 373 | in their abbrev. definition, or mode."
|
|---|
| 374 | "Lists all of the currently defined Word Abbrevs which contain a given string
|
|---|
| 375 | in their abbrev. definition, or mode."
|
|---|
| 376 | (declare (ignore p))
|
|---|
| 377 | (unless search-string
|
|---|
| 378 | (setq search-string
|
|---|
| 379 | (string-downcase
|
|---|
| 380 | (prompt-for-string
|
|---|
| 381 | :prompt "Apropos string: "
|
|---|
| 382 | :help "The string to search word abbrevs and definitions for."))))
|
|---|
| 383 | (multiple-value-bind (count mode-tables) (count-abbrevs)
|
|---|
| 384 | (with-pop-up-display (s :height (min (1+ count) 30))
|
|---|
| 385 | (unless (zerop (hash-table-count *global-abbrev-table*))
|
|---|
| 386 | (maphash #'(lambda (key val)
|
|---|
| 387 | (when (or (search search-string (string-downcase key))
|
|---|
| 388 | (search search-string (string-downcase val)))
|
|---|
| 389 | (write-abbrev key val nil s t)))
|
|---|
| 390 | *global-abbrev-table*))
|
|---|
| 391 | (dolist (modename mode-tables)
|
|---|
| 392 | (let ((table (variable-value 'Mode-Abbrev-Table :mode modename)))
|
|---|
| 393 | (if (search search-string (string-downcase modename))
|
|---|
| 394 | (maphash #'(lambda (key val)
|
|---|
| 395 | (write-abbrev key val modename s t))
|
|---|
| 396 | table)
|
|---|
| 397 | (maphash #'(lambda (key val)
|
|---|
| 398 | (when (or (search search-string (string-downcase key))
|
|---|
| 399 | (search search-string (string-downcase val)))
|
|---|
| 400 | (write-abbrev key val modename s t)))
|
|---|
| 401 | table))))
|
|---|
| 402 | (terpri s))))
|
|---|
| 403 |
|
|---|
| 404 |
|
|---|
| 405 |
|
|---|
| 406 | (defun count-abbrevs ()
|
|---|
| 407 | (let* ((count (hash-table-count *global-abbrev-table*))
|
|---|
| 408 | (mode-tables nil))
|
|---|
| 409 | (do-strings (which x *mode-names*)
|
|---|
| 410 | (declare (ignore x))
|
|---|
| 411 | (when (hemlock-bound-p 'Mode-Abbrev-Table :mode which)
|
|---|
| 412 | (let ((table-count (hash-table-count (variable-value 'Mode-Abbrev-Table
|
|---|
| 413 | :mode which))))
|
|---|
| 414 | (unless (zerop table-count)
|
|---|
| 415 | (incf count table-count)
|
|---|
| 416 | (push which mode-tables)))))
|
|---|
| 417 | (values count mode-tables)))
|
|---|
| 418 |
|
|---|
| 419 | |
|---|
| 420 |
|
|---|
| 421 | ;;; Edit Word Abbrevs Lets you edit the definition list directly.
|
|---|
| 422 |
|
|---|
| 423 | (defcommand "Edit Word Abbrevs" (p)
|
|---|
| 424 | "Allows direct editing of currently defined Word Abbrevs."
|
|---|
| 425 | "Allows direct editing of currently defined Word Abbrevs."
|
|---|
| 426 | (declare (ignore p))
|
|---|
| 427 | (when (getstring "Edit Word Abbrevs" *buffer-names*)
|
|---|
| 428 | (delete-buffer (getstring "Edit Word Abbrevs" *buffer-names*)))
|
|---|
| 429 | (let ((old-buf (current-buffer))
|
|---|
| 430 | (new-buf (make-buffer "Edit Word Abbrevs")))
|
|---|
| 431 | (change-to-buffer new-buf)
|
|---|
| 432 | (unwind-protect
|
|---|
| 433 | (progn
|
|---|
| 434 | (insert-word-abbrevs-command nil)
|
|---|
| 435 | (do-recursive-edit)
|
|---|
| 436 | (unless (equal #\newline (previous-character (buffer-end (current-point))))
|
|---|
| 437 | (insert-character (current-point) #\newline))
|
|---|
| 438 | (delete-all-word-abbrevs-command nil)
|
|---|
| 439 | (define-word-abbrevs-command nil))
|
|---|
| 440 | (progn
|
|---|
| 441 | (change-to-buffer old-buf)
|
|---|
| 442 | (delete-buffer new-buf)))))
|
|---|
| 443 |
|
|---|
| 444 |
|
|---|
| 445 |
|
|---|
| 446 | ;;; Insert Word Abbrevs Inserts a list of current definitions in the
|
|---|
| 447 | ;;; format that Define Word Abbrevs uses.
|
|---|
| 448 |
|
|---|
| 449 | (defcommand "Insert Word Abbrevs" (p)
|
|---|
| 450 | "Inserts into the current buffer a list of all currently defined abbrevs in the
|
|---|
| 451 | format used by \"Define Word Abbrevs\"."
|
|---|
| 452 | "Inserts into the current buffer a list of all currently defined abbrevs in the
|
|---|
| 453 | format used by \"Define Word Abbrevs\"."
|
|---|
| 454 |
|
|---|
| 455 | (declare (ignore p))
|
|---|
| 456 | (multiple-value-bind (x mode-tables)
|
|---|
| 457 | (count-abbrevs)
|
|---|
| 458 | (declare (ignore x))
|
|---|
| 459 | (with-output-to-mark (stream (current-point) :full)
|
|---|
| 460 | (maphash #'(lambda (key val)
|
|---|
| 461 | (write-abbrev key val nil stream))
|
|---|
| 462 | *global-abbrev-table*)
|
|---|
| 463 |
|
|---|
| 464 | (dolist (mode mode-tables)
|
|---|
| 465 | (let ((modename (if (listp mode) (car mode) mode)))
|
|---|
| 466 | (maphash #'(lambda (key val)
|
|---|
| 467 | (write-abbrev key val modename stream))
|
|---|
| 468 | (variable-value 'Mode-Abbrev-Table :mode modename)))))))
|
|---|
| 469 |
|
|---|
| 470 |
|
|---|
| 471 |
|
|---|
| 472 | ;;; Define Word Abbrevs Defines set of abbrevs from a definition list in
|
|---|
| 473 | ;;; the buffer.
|
|---|
| 474 |
|
|---|
| 475 | (defcommand "Define Word Abbrevs" (p)
|
|---|
| 476 | "Defines Word Abbrevs from the definition list in the current buffer. The
|
|---|
| 477 | definition list must be in the format produced by \"Insert Word Abbrevs\"."
|
|---|
| 478 | "Defines Word Abbrevs from the definition list in the current buffer. The
|
|---|
| 479 | definition list must be in the format produced by \"Insert Word Abbrevs\"."
|
|---|
| 480 |
|
|---|
| 481 | (declare (ignore p))
|
|---|
| 482 | (with-input-from-region (file (buffer-region (current-buffer)))
|
|---|
| 483 | (read-abbrevs file)))
|
|---|
| 484 |
|
|---|
| 485 | |
|---|
| 486 |
|
|---|
| 487 | ;;; Read Word Abbrev file <filename> Define word abbrevs from a definition file.
|
|---|
| 488 |
|
|---|
| 489 | ;;; Ignores all lines less than 4 characters, i.e. blankspace or errors. That is
|
|---|
| 490 | ;;; the minimum number of characters possible to define an abbrev. It thinks the
|
|---|
| 491 | ;;; current abbrev "wraps" if there is no #\" at the end of the line or there are
|
|---|
| 492 | ;;; two #\"s at the end of the line (unless that is the entire definition string,
|
|---|
| 493 | ;;; i.e, a null-abbrev).
|
|---|
| 494 |
|
|---|
| 495 | ;;; The format of the Abbrev files is
|
|---|
| 496 | ;;;
|
|---|
| 497 | ;;; ABBREV<tab><tab>"ABBREV DEFINITION"
|
|---|
| 498 | ;;;
|
|---|
| 499 | ;;; for Global Abbrevs, and
|
|---|
| 500 | ;;;
|
|---|
| 501 | ;;; ABBREV<tab>(MODE)<tab>"ABBREV DEFINITION"
|
|---|
| 502 | ;;;
|
|---|
| 503 | ;;; for Modal Abbrevs.
|
|---|
| 504 | ;;; Double-quotes contained within the abbrev definition are doubled. If the first
|
|---|
| 505 | ;;; line of an abbrev definition is not closed by a single double-quote, then
|
|---|
| 506 | ;;; the subsequent lines are read in until a single double-quote is found.
|
|---|
| 507 |
|
|---|
| 508 | (defcommand "Read Word Abbrev File" (p &optional filename)
|
|---|
| 509 | "Reads in a file of previously defined abbrev definitions."
|
|---|
| 510 | "Reads in a file of previously defined abbrev definitions."
|
|---|
| 511 | (declare (ignore p))
|
|---|
| 512 | (setf (value abbrev-pathname-defaults)
|
|---|
| 513 | (if filename
|
|---|
| 514 | filename
|
|---|
| 515 | (prompt-for-file
|
|---|
| 516 | :prompt "Name of abbrev file: "
|
|---|
| 517 | :help "The name of the abbrev file to load."
|
|---|
| 518 | :default (value abbrev-pathname-defaults)
|
|---|
| 519 | :must-exist nil)))
|
|---|
| 520 | (with-open-file (file (value abbrev-pathname-defaults) :direction :input
|
|---|
| 521 | :element-type 'base-char :if-does-not-exist :error)
|
|---|
| 522 | (read-abbrevs file)))
|
|---|
| 523 |
|
|---|
| 524 |
|
|---|
| 525 | ;;; Does the actual defining of abbrevs from a given stream, expecting tabs and
|
|---|
| 526 | ;;; doubled double-quotes.
|
|---|
| 527 |
|
|---|
| 528 | (defun read-abbrevs (file)
|
|---|
| 529 | (do ((line (read-line file nil nil)
|
|---|
| 530 | (read-line file nil nil)))
|
|---|
| 531 | ((null line))
|
|---|
| 532 | (unless (< (length line) 4)
|
|---|
| 533 | (let* ((tab (position #\tab line))
|
|---|
| 534 | (tab2 (position #\tab line :start (1+ tab)))
|
|---|
| 535 | (abbrev (subseq line 0 tab))
|
|---|
| 536 | (modename (subseq line (1+ tab) tab2))
|
|---|
| 537 | (expansion (do* ((last (1+ (position #\" line))
|
|---|
| 538 | (if found (min len (1+ found)) 0))
|
|---|
| 539 | (len (length line))
|
|---|
| 540 | (found (if (position #\" line :start last)
|
|---|
| 541 | (1+ (position #\" line :start last)))
|
|---|
| 542 | (if (position #\" line :start last)
|
|---|
| 543 | (1+ (position #\" line :start last))))
|
|---|
| 544 | (expansion (subseq line last (if found found len))
|
|---|
| 545 | (concatenate 'simple-string expansion
|
|---|
| 546 | (subseq line last
|
|---|
| 547 | (if found found
|
|---|
| 548 | len)))))
|
|---|
| 549 | ((and (or (null found) (= found len))
|
|---|
| 550 | (equal #\" (char line (1- len)))
|
|---|
| 551 | (or (not (equal #\" (char line (- len 2))))
|
|---|
| 552 | (= (- len 3) tab2)))
|
|---|
| 553 | (subseq expansion 0 (1- (length expansion))))
|
|---|
| 554 |
|
|---|
| 555 | (when (null found)
|
|---|
| 556 | (setq line (read-line file nil nil)
|
|---|
| 557 | last 0
|
|---|
| 558 | len (length line)
|
|---|
| 559 | found (if (position #\" line)
|
|---|
| 560 | (1+ (position #\" line)))
|
|---|
| 561 | expansion (format nil "~A~%~A" expansion
|
|---|
| 562 | (subseq line 0 (if found
|
|---|
| 563 | found
|
|---|
| 564 | 0))))))))
|
|---|
| 565 |
|
|---|
| 566 | (cond ((equal modename "")
|
|---|
| 567 | (setf (gethash abbrev *global-abbrev-table*)
|
|---|
| 568 | expansion))
|
|---|
| 569 | (t (setq modename (subseq modename 1 (1- (length modename))))
|
|---|
| 570 | (unless (hemlock-bound-p 'Mode-Abbrev-Table
|
|---|
| 571 | :mode modename)
|
|---|
| 572 | (defhvar "Mode Abbrev Table"
|
|---|
| 573 | "Hash Table of Mode Abbrevs"
|
|---|
| 574 | :value (make-hash-table :test #'equal)
|
|---|
| 575 | :mode modename))
|
|---|
| 576 | (setf (gethash abbrev (variable-value
|
|---|
| 577 | 'Mode-Abbrev-Table :mode modename))
|
|---|
| 578 | expansion)))))))
|
|---|
| 579 |
|
|---|
| 580 |
|
|---|
| 581 | ;;; Write Word Abbrev File Make a definition file from current abbrevs.
|
|---|
| 582 |
|
|---|
| 583 | (defcommand "Write Word Abbrev File" (p &optional filename)
|
|---|
| 584 | "Saves the currently defined Abbrevs to a file."
|
|---|
| 585 | "Saves the currently defined Abbrevs to a file."
|
|---|
| 586 | (declare (ignore p))
|
|---|
| 587 | (unless filename
|
|---|
| 588 | (setq filename
|
|---|
| 589 | (prompt-for-file
|
|---|
| 590 | :prompt "Write abbrevs to file: "
|
|---|
| 591 | :default (value abbrev-pathname-defaults)
|
|---|
| 592 | :help "Name of the file to write current abbrevs to."
|
|---|
| 593 | :must-exist nil)))
|
|---|
| 594 | (with-open-file (file filename :direction :output
|
|---|
| 595 | :element-type 'base-char :if-exists :supersede
|
|---|
| 596 | :if-does-not-exist :create)
|
|---|
| 597 | (multiple-value-bind (x mode-tables) (count-abbrevs)
|
|---|
| 598 | (declare (ignore x))
|
|---|
| 599 | (maphash #'(lambda (key val)
|
|---|
| 600 | (write-abbrev key val nil file))
|
|---|
| 601 | *global-abbrev-table*)
|
|---|
| 602 |
|
|---|
| 603 | (dolist (modename mode-tables)
|
|---|
| 604 | (let ((mode (if (listp modename) (car modename) modename)))
|
|---|
| 605 | (maphash #'(lambda (key val)
|
|---|
| 606 | (write-abbrev key val mode file))
|
|---|
| 607 | (variable-value 'Mode-Abbrev-Table :mode mode))))))
|
|---|
| 608 | (let ((tn (truename filename)))
|
|---|
| 609 | (setf (value abbrev-pathname-defaults) tn)
|
|---|
| 610 | (message "~A written." (namestring tn))))
|
|---|
| 611 |
|
|---|
| 612 |
|
|---|
| 613 |
|
|---|
| 614 | ;;; Append to Word Abbrev File Appends to a file changed abbrev
|
|---|
| 615 | ;;; definitions since last dumping.
|
|---|
| 616 |
|
|---|
| 617 | (defcommand "Append to Word Abbrev File" (p &optional filename)
|
|---|
| 618 | "Appends Abbrevs defined or redefined since the last save to a file."
|
|---|
| 619 | "Appends Abbrevs defined or redefined since the last save to a file."
|
|---|
| 620 | (declare (ignore p))
|
|---|
| 621 | (cond
|
|---|
| 622 | (*new-abbrevs*
|
|---|
| 623 | (unless filename
|
|---|
| 624 | (setq filename
|
|---|
| 625 | (prompt-for-file
|
|---|
| 626 | :prompt
|
|---|
| 627 | "Append incremental abbrevs to file: "
|
|---|
| 628 | :default (value abbrev-pathname-defaults)
|
|---|
| 629 | :must-exist nil
|
|---|
| 630 | :help "Filename to append recently defined Abbrevs to.")))
|
|---|
| 631 | (write-incremental :append filename))
|
|---|
| 632 | (t
|
|---|
| 633 | (message "No Abbrev definitions have been changed since the last write."))))
|
|---|
| 634 |
|
|---|
| 635 |
|
|---|
| 636 | (defun write-incremental (mode filename)
|
|---|
| 637 | (with-open-file (file filename :direction :output
|
|---|
| 638 | :element-type 'base-char
|
|---|
| 639 | :if-exists mode :if-does-not-exist :create)
|
|---|
| 640 | (dolist (def *new-abbrevs*)
|
|---|
| 641 | (let ((abb (car def))
|
|---|
| 642 | (val (second def))
|
|---|
| 643 | (mode (third def)))
|
|---|
| 644 | (write-abbrev abb val mode file))))
|
|---|
| 645 | (let ((tn (truename filename)))
|
|---|
| 646 | (setq *new-abbrevs* nil)
|
|---|
| 647 | (setf (value abbrev-pathname-defaults) tn)
|
|---|
| 648 | (message "~A written." (namestring tn))))
|
|---|
| 649 |
|
|---|
| 650 |
|
|---|
| 651 | ;;; Given an Abbrev, expansion, mode (nil for Global), and stream, this function
|
|---|
| 652 | ;;; writes to the stream with doubled double-quotes and stuff.
|
|---|
| 653 | ;;; If the flag is true, then the output is in a pretty format (like "List Word
|
|---|
| 654 | ;;; Abbrevs" uses), otherwise output is in tabbed format (like "Write Word
|
|---|
| 655 | ;;; Abbrev File" uses).
|
|---|
| 656 |
|
|---|
| 657 | (defun write-abbrev (abbrev expansion modename file &optional flag)
|
|---|
| 658 | (if flag
|
|---|
| 659 | (if modename
|
|---|
| 660 | (format file "~5t~A~20t(~A)~35t\"" abbrev modename); pretty format
|
|---|
| 661 | (format file "~5t~A~35t\"" abbrev)) ; pretty format
|
|---|
| 662 | (cond (modename
|
|---|
| 663 | (write-string abbrev file)
|
|---|
| 664 | (write-char #\tab file)
|
|---|
| 665 | (format file "(~A)" modename) ; "~A<tab>(~A)<tab>\""
|
|---|
| 666 | (write-char #\tab file)
|
|---|
| 667 | (write-char #\" file))
|
|---|
| 668 | (t
|
|---|
| 669 | (write-string abbrev file)
|
|---|
| 670 | (write-char #\tab file) ; "~A<tab><tab>\""
|
|---|
| 671 | (write-char #\tab file)
|
|---|
| 672 | (write-char #\" file))))
|
|---|
| 673 | (do* ((prev 0 found)
|
|---|
| 674 | (found (position #\" expansion)
|
|---|
| 675 | (position #\" expansion :start found)))
|
|---|
| 676 | ((not found)
|
|---|
| 677 | (write-string expansion file :start prev)
|
|---|
| 678 | (write-char #\" file)
|
|---|
| 679 | (terpri file))
|
|---|
| 680 | (incf found)
|
|---|
| 681 | (write-string expansion file :start prev :end found)
|
|---|
| 682 | (write-char #\" file)))
|
|---|
| 683 |
|
|---|
| 684 |
|
|---|
| 685 | (defcommand "Abbrev Mode" (p)
|
|---|
| 686 | "Put current buffer in Abbrev mode."
|
|---|
| 687 | "Put current buffer in Abbrev mode."
|
|---|
| 688 | (declare (ignore p))
|
|---|
| 689 | (setf (buffer-minor-mode (current-buffer) "Abbrev")
|
|---|
| 690 | (not (buffer-minor-mode (current-buffer) "Abbrev"))))
|
|---|
