From: Chris Hanson <org/chris-hanson/cph>
Date: Mon, 28 Feb 2000 22:50:55 +0000 (+0000)
Subject: Initial revision
X-Git-Tag: 20090517-FFI~4225
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=1a0bd6c2afaad2f95a29ddb392b02b3a6104fc89;p=mit-scheme.git

Initial revision
---

diff --git a/v7/src/edwin/abbrev.scm b/v7/src/edwin/abbrev.scm
new file mode 100644
index 000000000..e5c0c0638
--- /dev/null
+++ b/v7/src/edwin/abbrev.scm
@@ -0,0 +1,627 @@
+;;; -*-Scheme-*-
+;;;
+;;; $Id: abbrev.scm,v 1.1 2000/02/28 22:50:55 cph Exp $
+;;;
+;;; Copyright (c) 2000 Massachusetts Institute of Technology
+;;;
+;;; This program is free software; you can redistribute it and/or
+;;; modify it under the terms of the GNU General Public License as
+;;; published by the Free Software Foundation; either version 2 of the
+;;; License, or (at your option) any later version.
+;;;
+;;; This program is distributed in the hope that it will be useful,
+;;; but WITHOUT ANY WARRANTY; without even the implied warranty of
+;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
+;;; General Public License for more details.
+;;;
+;;; You should have received a copy of the GNU General Public License
+;;; along with this program; if not, write to the Free Software
+;;; Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
+
+;;;; Abbrev Mode
+
+(declare (usual-integrations))
+
+;;;; Low-level data structures
+
+(define make-abbrev-table make-string-hash-table)
+(define abbrev-table? hash-table?)
+
+(define-structure (abbrev-entry (type-descriptor abbrev-entry-rtd))
+  (expansion #f read-only #t)
+  (hook #f read-only #t)
+  (count 0))
+
+(define (clear-abbrev-table table)
+  (set! abbrevs-changed? #t)
+  (hash-table/clear! table))
+
+(define (define-abbrev table abbrev expansion #!optional hook count)
+  (if (not (abbrev-table? table))
+      (error:wrong-type-argument table "abbrev table" 'DEFINE-ABBREV))
+  (if (not (string? abbrev))
+      (error:wrong-type-argument abbrev "string" 'DEFINE-ABBREV))
+  (if (not (string? expansion))
+      (error:wrong-type-argument expansion "string" 'DEFINE-ABBREV))
+  (if (not (or (default-object? hook) (not hook) (symbol? hook)))
+      (error:wrong-type-argument hook "symbol" 'DEFINE-ABBREV))
+  (if (not (or (default-object? count) (exact-nonnegative-integer? count)))
+      (error:wrong-type-argument count
+				 "exact non-negative integer"
+				 'DEFINE-ABBREV))
+  (set! abbrevs-changed? #t)
+  (hash-table/put! table
+		   (string-downcase abbrev)
+		   (make-abbrev-entry
+		    expansion
+		    (if (default-object? hook) #f hook)
+		    (if (default-object? count) 0 count))))
+
+(define (define-global-abbrev abbrev expansion)
+  (define-abbrev (ref-variable global-abbrev-table #f) abbrev expansion))
+
+(define (define-mode-abbrev abbrev expansion)
+  (let ((table (ref-variable local-abbrev-table)))
+    (if (not table)
+	(error "Major mode has no abbrev table."))
+    (define-abbrev table abbrev expansion)))
+
+(define (undefine-abbrev table abbrev)
+  (if (not (abbrev-table? table))
+      (error:wrong-type-argument table "abbrev table" 'UNDEFINE-ABBREV))
+  (if (not (string? abbrev))
+      (error:wrong-type-argument abbrev "string" 'UNDEFINE-ABBREV))
+  (set! abbrevs-changed? #t)
+  (hash-table/remove! table (string-downcase abbrev)))
+
+(define (abbrev-entry abbrev where)
+  (let ((abbrev
+	 (string-downcase
+	  (cond ((string? abbrev) abbrev)
+		((symbol? abbrev) (symbol->string abbrev))
+		(else
+		 (error:wrong-type-argument abbrev "string"
+					    'ABBREV-EXPANSION))))))
+    (if (abbrev-table? where)
+	(hash-table/get where abbrev #f)
+	(let ((buffer (if (not where) (selected-buffer) where)))
+	  (or (let ((table (ref-variable local-abbrev-table buffer)))
+		(and table
+		     (hash-table/get table abbrev #f)))
+	      (hash-table/get (ref-variable global-abbrev-table #f)
+			      abbrev
+			      #f))))))
+
+(define (abbrev-expansion abbrev where)
+  (let ((entry (abbrev-entry abbrev where)))
+    (and entry
+	 (abbrev-entry-expansion entry))))
+
+(define (define-abbrev-table name definitions)
+  (let ((table (make-abbrev-table)))
+    (for-each
+     (lambda (definition)
+       (if (not (and (list? definition)
+		     (= 4 (length definition))
+		     (string? (car definition))
+		     (string? (cadr definition))
+		     (symbol? (caddr definition))
+		     (exact-nonnegative-integer? (cadddr definition))))
+	   (error "Malformed abbrev definition:" definition))
+       (define-abbrev table
+	 (car definition)
+	 (cadr definition)
+	 (if (eq? 'NIL (caddr definition)) #f (caddr definition))
+	 (cadddr definition)))
+     definitions)
+    (set-variable-default-value! (name->variable name 'INTERN) table)
+    (let ((names (ref-variable abbrev-table-name-list #f)))
+      (if (not (memq name names))
+	  (set-variable! abbrev-table-name-list (cons name names) #f)))))
+
+(define (get-named-abbrev-table name)
+  (let ((table (variable-default-value (name->variable name 'ERROR))))
+    (if (not (abbrev-table? table))
+	(error:bad-range-argument name 'GET-NAMED-ABBREV-TABLE))
+    table))
+
+;;;; Variables
+
+(define-variable abbrev-table-name-list
+  "List of symbols whose values are abbrev tables."
+  (list 'FUNDAMENTAL-MODE-ABBREV-TABLE 'GLOBAL-ABBREV-TABLE)
+  (lambda (object) (list-of-type? object symbol?)))
+
+(define-variable global-abbrev-table
+  "The abbrev table whose abbrevs affect all buffers.
+Each buffer may also have a local abbrev table.
+If it does, the local table overrides the global one
+for any particular abbrev defined in both."
+  (make-abbrev-table)
+  abbrev-table?)
+
+(define-variable fundamental-mode-abbrev-table
+  "The abbrev table of mode-specific abbrevs for Fundamental Mode."
+  (make-abbrev-table)
+  abbrev-table?)
+
+(define-variable-per-buffer local-abbrev-table
+  "Local (mode-specific) abbrev table of current buffer."
+  #f
+  (lambda (object)
+    (or (not object)
+	(abbrev-table? object))))
+
+(define-variable abbrev-all-caps
+  "Set true means expand multi-word abbrevs all caps if abbrev was so."
+  #f
+  boolean?)
+
+(define-variable save-abbrevs
+  "True means save word abbrevs too when files are saved.
+Loading an abbrev file sets this to #t."
+  #f
+  boolean?)
+
+(define-variable only-global-abbrevs
+  "True means user plans to use global abbrevs only.
+This makes the commands that normally define mode-specific abbrevs
+define global abbrevs instead."
+  #f
+  boolean?)
+
+(define-variable abbrev-file-name
+  "Default name of file to read abbrevs from."
+  (os/abbrev-file-name)
+  string?)
+
+(define-variable pre-abbrev-expand-hook
+  "An event distributor that is invoked prior to expanding an abbrev.
+The events are called with a single argument: the current point marker."
+  (make-event-distributor))
+
+(define abbrevs-changed? #f)
+
+;;;; Abbrev definition
+
+(define-command add-mode-abbrev
+  "Define mode-specific abbrev for last word(s) before point.
+Argument is how many words before point form the expansion;
+or zero means the region is the expansion.
+A negative argument means to undefine the specified abbrev.
+Reads the abbreviation in the minibuffer.
+
+Don't use this procedure in a Scheme program; use `define-abbrev' instead."
+  "p"
+  (lambda (n)
+    (add-abbrev (if (ref-variable only-global-abbrevs)
+		    (ref-variable global-abbrev-table #f)
+		    (or (ref-variable local-abbrev-table)
+			(editor-error "No per-mode abbrev table.")))
+		"Mode"
+		n)))
+
+(define-command add-global-abbrev
+  "Define global (all modes) abbrev for last word(s) before point.
+The prefix argument specifies the number of words before point that form the
+expansion; or zero means the region is the expansion.
+A negative argument means to undefine the specified abbrev.
+This command uses the minibuffer to read the abbreviation.
+
+Don't use this procedure in a Scheme program; use `define-abbrev' instead."
+  "p"
+  (lambda (n)
+    (add-abbrev (ref-variable global-abbrev-table #f) "Global" n)))
+
+(define-command inverse-add-mode-abbrev
+  "Define last word before point as a mode-specific abbrev.
+With prefix argument N, defines the Nth word before point.
+This command uses the minibuffer to read the expansion.
+Expands the abbreviation after defining it."
+  "p"
+  (lambda (n)
+    (inverse-add-abbrev (if (ref-variable only-global-abbrevs)
+			    (ref-variable global-abbrev-table #f)
+			    (or (ref-variable local-abbrev-table)
+				(editor-error "No per-mode abbrev table.")))
+			"Mode"
+			n)))
+
+(define-command inverse-add-global-abbrev
+  "Define last word before point as a global (mode-independent) abbrev.
+With prefix argument N, defines the Nth word before point.
+This command uses the minibuffer to read the expansion.
+Expands the abbreviation after defining it."
+  "p"
+  (lambda (n)
+    (inverse-add-abbrev (ref-variable global-abbrev-table #f)
+			"Global"
+			n)))
+
+(define (add-abbrev table type n)
+  (let ((expansion
+	 (and (>= n 0)
+	      (extract-string
+	       (if (= n 0)
+		   (current-mark)
+		   (backward-word (current-point) n 'LIMIT))))))
+    (let ((name
+	   (prompt-for-string
+	    (if expansion
+		(string-append type " abbrev for \"" expansion "\"")
+		(string-append "Undefine " type " abbrev"))
+	    #f)))
+      (if expansion
+	  (conditionally-define-abbrev table name expansion)
+	  (undefine-abbrev table name)))))
+
+(define (inverse-add-abbrev table type n)
+  (let* ((m (backward-word (current-point) n 'LIMIT))
+	 (location (forward-word m 1 'LIMIT))
+	 (name (extract-string m location))
+	 (expansion
+	  (prompt-for-string
+	   (string-append type " expansion for \"" name "\"")
+	   #f)))
+    (if (conditionally-define-abbrev table name expansion)
+	((ref-command expand-abbrev) location))))
+
+(define (conditionally-define-abbrev table name expansion)
+  (let ((do-it?
+	 (let ((expansion (abbrev-expansion name table)))
+	   (or (not expansion)
+	       (prompt-for-confirmation?
+		(string-append name
+			       " expands to \""
+			       expansion
+			       "\"; redefine"))))))
+    (if do-it?
+	(define-abbrev table name expansion))
+    do-it?))
+
+;;;; Abbrev expansion
+
+(define-command expand-abbrev
+  "Expand the abbrev before point, if there is an abbrev there.
+Effective when explicitly called even when `abbrev-mode' is nil.
+Returns the abbrev symbol, if expansion took place."
+  "d"
+  (lambda (mark)
+    (event-distributor/invoke! (ref-variable pre-abbrev-expand-hook) mark)
+    (let* ((start
+	    (let ((buffer (selected-buffer)))
+	      (let ((start (buffer-get buffer 'ABBREV-START-LOCATION #f)))
+		(if start
+		    (begin
+		      (buffer-remove! buffer 'ABBREV-START-LOCATION)
+		      (if (eqv? #\- (extract-right-char start))
+			  (delete-right-char start))
+		      (mark-temporary! start)
+		      start)
+		    (backward-word mark 1 #f)))))
+	   (end
+	    (and start
+		 (let ((end (forward-word start 1 'LIMIT)))
+		   (if (mark> end mark)
+		       mark
+		       end)))))
+      (and start
+	   (mark< start end)
+	   (let* ((abbrev (extract-string start end))
+		  (entry (abbrev-entry abbrev #f)))
+	     (and entry
+		  (begin
+		    ;; Add an undo boundary, in case we are doing
+		    ;; this for a self-inserting command which has
+		    ;; avoided making one so far.
+		    (undo-boundary! end)
+		    (buffer-put! (selected-buffer)
+				 'LAST-ABBREV
+				 (let ((expansion
+					(abbrev-entry-expansion entry)))
+				   (and expansion
+					(vector abbrev expansion start))))
+		    (set-abbrev-entry-count!
+		     entry
+		     (+ (abbrev-entry-count entry) 1))
+		    (let ((expansion (abbrev-entry-expansion entry)))
+		      (if (string? expansion)
+			  (let ((start (mark-right-inserting-copy start))
+				(end (mark-left-inserting-copy end)))
+			    (let ((r (make-region start end)))
+			      (region-delete! r)
+			      (insert-string expansion start)
+			      (cond ((string-upper-case? abbrev)
+				     (if (or (ref-variable abbrev-all-caps)
+					     (= (count-words-region r) 1))
+					 (upcase-region r)
+					 (capitalize-region r)))
+				    ((and (not (string-lower-case? abbrev))
+					  (let ((m (forward-to-word start #f)))
+					    (and m
+						 (mark< m end)
+						 m)))
+				     => (lambda (m)
+					  (upcase-region
+					   (make-region m (mark1+ m)))))))
+			    (mark-temporary! end)
+			    (mark-temporary! start))))
+		    (let ((hook (abbrev-entry-hook entry)))
+		      (cond ((symbol? hook)
+			     ((eval hook (->environment '(EDWIN)))))
+			    (hook
+			     (error "Abbrev hook must be symbol:" hook))))
+		    abbrev)))))))
+
+(define-command unexpand-abbrev
+  "Undo the expansion of the last abbrev that expanded.
+This differs from ordinary undo in that other editing done since then
+is not undone."
+  ()
+  (lambda ()
+    (let ((last (buffer-get (selected-buffer) 'LAST-ABBREV #f)))
+      (if last
+	  (let ((abbrev (vector-ref last 0))
+		(expansion (vector-ref last 1))
+		(start (vector-ref last 2)))
+	    (let ((end (mark+ start (string-length expansion))))
+	      (if (not (string-ci=? (extract-string start end) expansion))
+		  (editor-error "Can't expand abbrev; contents changed."))
+	      (delete-string start end)
+	      (insert-string abbrev start))
+	    (buffer-remove! (selected-buffer) 'LAST-ABBREV))))))
+
+(define-command abbrev-prefix-mark
+  "Mark current point as the beginning of an abbrev.
+Abbrev to be expanded starts here rather than at beginning of word.
+This way, you can expand an abbrev with a prefix: insert the prefix,
+use this command, then insert the abbrev."
+  "P"
+  (lambda (argument)
+    (if (not argument)
+	((ref-command expand-abbrev) (current-point)))
+    (buffer-put! (selected-buffer)
+		 'ABBREV-START-LOCATION
+		 (mark-right-inserting-copy (current-point)))
+    (insert-string "-")))
+
+(define-command expand-region-abbrevs
+  "For abbrev occurrence in the region, offer to expand it.
+The user is asked to type y or n for each occurrence.
+A prefix argument means don't query; expand all abbrevs."
+  "r\nP"
+  (lambda (region no-query?)
+    (let ((end (region-end region)))
+      (let loop ((start (region-start region)))
+	(let ((ws (forward-to-word start #f)))
+	  (if (and ws (mark< ws end))
+	      (let ((we (forward-word ws 1 'LIMIT)))
+		(if (and (mark<= we end)
+			 (let ((word (extract-string ws we)))
+			   (and (abbrev-expansion word #f)
+				(or no-query?
+				    (prompt-for-confirmation?
+				     (string-append "Expand \"" word "\""))))))
+		    (let ((we (mark-left-inserting-copy we)))
+		      ((ref-command expand-abbrev) we)
+		      (mark-temporary! we)
+		      (loop we))
+		    (loop we)))))))))
+
+(define-minor-mode abbrev "Abbrev"
+  "Minor mode in which abbrevs are expanded.")
+
+(define-command abbrev-mode
+  "Toggle abbrev mode.
+With argument ARG, turn abbrev mode on iff ARG is positive.
+In abbrev mode, inserting an abbreviation causes it to expand
+and be replaced by its expansion."
+  "P"
+  (lambda (argument)
+    (let ((mode (ref-mode-object abbrev)))
+      (if (if argument
+	      (> (command-argument-value argument) 0)
+	      (not (current-minor-mode? mode)))
+	  (enable-current-minor-mode! mode)
+	  (disable-current-minor-mode! mode)))))
+
+;;;; Editing abbrevs
+
+(define-command edit-abbrevs
+  "Alter abbrev definitions by editing a list of them.
+Selects a buffer containing a list of abbrev definitions.
+You can edit them and type \\<edit-abbrevs>\\[edit-abbrevs-redefine] to redefine abbrevs
+according to your editing.
+Buffer contains a header line for each abbrev table,
+ which is the abbrev table name in parentheses.
+This is followed by one line per abbrev in that table:
+NAME   USECOUNT   EXPANSION   HOOK
+where NAME and EXPANSION are strings with quotes,
+USECOUNT is an integer, and HOOK is any valid function
+or may be omitted (it is usually omitted)."
+  ()
+  (lambda () (select-buffer (prepare-abbrev-list-buffer))))
+
+(define-command list-abbrevs
+  "Display a list of all defined abbrevs."
+  ()
+  (lambda () (pop-up-buffer (prepare-abbrev-list-buffer) #f #f)))
+
+(define (prepare-abbrev-list-buffer)
+  (let ((buffer (find-or-create-buffer "*Abbrevs*")))
+    (buffer-reset! buffer)
+    (insert-abbrev-table-descriptions)
+    (buffer-not-modified! buffer)
+    (set-buffer-point! buffer (buffer-start buffer))
+    (set-buffer-major-mode! buffer (ref-mode-object edit-abbrevs))
+    buffer))
+
+(define-command insert-abbrevs
+  "Insert after point a description of all defined abbrevs.
+Mark is set after the inserted text."
+  ()
+  (lambda ()
+    (insert-abbrev-table-descriptions)
+    (set-current-mark! (current-point))))
+
+(define (insert-abbrev-table-descriptions)
+  (for-each
+   (lambda (name)
+     (let ((table (get-named-abbrev-table name)))
+       (insert-string "(")
+       (insert-string (symbol->string name))
+       (insert-string ")\n\n")
+       (hash-table/for-each table
+	 (lambda (abbrev entry)
+	   (if (abbrev-entry-expansion entry)
+	       (begin
+		 (insert-string abbrev)
+		 (indent-to 15 1)
+		 (insert-string (number->string (abbrev-entry-count entry)))
+		 (indent-to 20 1)
+		 (insert-string (abbrev-entry-expansion entry))
+		 (if (abbrev-entry-hook entry)
+		     (begin
+		       (indent-to 45 1)
+		       (insert-string (abbrev-entry-hook entry))))
+		 (insert-newline)))))
+       (insert-string "\n\n")))
+   (ref-variable abbrev-table-name-list #f)))
+
+(define-major-mode edit-abbrevs fundamental "Edit-Abbrevs"
+  "Major mode for editing the list of abbrev definitions."
+  (lambda (buffer)
+    buffer
+    unspecific))
+
+(define-key 'edit-abbrevs '(#\C-x #\C-s) 'edit-abbrevs-redefine)
+(define-key 'edit-abbrevs '(#\C-x #\C-c) 'edit-abbrevs-redefine)
+
+(define-command edit-abbrevs-redefine
+  "Redefine abbrevs according to current buffer contents."
+  ()
+  (lambda ()
+    ((ref-command define-abbrevs) #t)
+    (buffer-not-modified! (selected-buffer))))
+
+(define-command define-abbrevs
+  "Define abbrevs according to current visible buffer contents.
+See documentation of \\[edit-abbrevs] for info on the format of the
+text you must have in the buffer.
+With argument, eliminate all abbrev definitions except
+the ones defined from the buffer now."
+  "P"
+  (lambda (argument)
+    (if argument ((ref-command kill-all-abbrevs)))
+    (let ((buffer (selected-buffer)))
+      (let read-tables ((start (buffer-start buffer)))
+	(let ((m (re-search-forward "^(" start)))
+	  (define (read-expr)
+	    (with-input-from-mark m read
+	      (lambda (expr m*)
+		(set! m m*)
+		expr)))
+	  (if m
+	      (let ((name (read-expr)))
+		(set! m (forward-line m 1 'LIMIT))
+		(define-abbrev-table name
+		  (let loop ()
+		    (set! m (forward-line m 1 'LIMIT))
+		    (if (line-end? m)
+			'()
+			(let* ((abbrev (read-expr))
+			       (count (read-expr))
+			       (expansion (read-expr)))
+			  (set! m (skip-chars-backward " \t\n\f" m))
+			  (let ((hook
+				 (and (not (line-end? m))
+				      (read-expr))))
+			    (set! m (skip-chars-backward " \t\n\f" m))
+			    (cons (list abbrev expansion hook count)
+				  (loop)))))))
+		(read-tables m))))))))
+
+(define-command kill-all-abbrevs
+  "Undefine all defined abbrevs."
+  ()
+  (lambda ()
+    (for-each (lambda (name)
+		(clear-abbrev-table (get-named-abbrev-table name)))
+	      (ref-variable abbrev-table-name-list #f))
+    (set-variable! abbrev-table-name-list '() #f)))
+
+;;;; Abbrev-file I/O
+
+(define-command read-abbrev-file
+  "Read abbrev definitions from file written with `write-abbrev-file'.
+Argument FILENAME is the name of the file to read;
+it defaults to the value of `abbrev-file-name'."
+  (lambda ()
+    (list
+     (prompt-for-existing-file "Read abbrev file"
+			       (ref-variable abbrev-file-name #f))))
+  (lambda (filename)
+    (let ((filename (abbrev-file/filename filename)))
+      (message "Loading " filename "...")
+      (quietly-read-abbrev-file filename)
+      (append-message "done"))))
+
+(define (quietly-read-abbrev-file #!optional filename)
+  (let ((filename
+	 (abbrev-file/filename
+	  (if (default-object? filename) #f filename))))
+    (load-edwin-file filename '(EDWIN) #f)
+    (set-variable! save-abbrevs #t #f)
+    (set! abbrevs-changed? #f)
+    unspecific))
+
+(define-command write-abbrev-file
+  "Write all abbrev definitions to a file of Lisp code.
+The file written can be loaded in another session to define the same abbrevs.
+The argument FILENAME is the file name to write."
+  (lambda ()
+    (list
+     (prompt-for-file "Write abbrev file"
+		      (merge-pathnames (ref-variable abbrev-file-name #f)))))
+  (lambda (filename)
+    (let ((filename (abbrev-file/filename filename)))
+      (call-with-output-file filename
+	(lambda (port)
+	  (for-each
+	   (lambda (name)
+	     (let ((table (get-named-abbrev-table name)))
+	       (write-string "(define-abbrev-table '" port)
+	       (write name port)
+	       (write-string " '(" port)
+	       (newline port)
+	       (hash-table/for-each table
+		 (lambda (abbrev entry)
+		   (if (abbrev-entry-expansion entry)
+		       (begin
+			 (write-string "    " port)
+			 (write (list abbrev
+				      (abbrev-entry-expansion entry)
+				      (or (abbrev-entry-hook entry) 'NIL)
+				      (abbrev-entry-count entry))
+				port)
+			 (newline port)))))
+	       (write-string "    ))" port)
+	       (newline port)
+	       (newline port)))
+	   (ref-variable abbrev-table-name-list #f)))))))
+
+(define (abbrev-file/filename filename)
+  (or filename (ref-variable abbrev-file-name #f)))
+
+(define (maybe-save-abbrevs no-confirmation?)
+  (and (ref-variable save-abbrevs #f)
+       abbrevs-changed?
+       (begin
+	 (if (or no-confirmation?
+		 (prompt-for-confirmation?
+		  (string-append "Save abbrevs in "
+				 (ref-variable abbrev-file-name #f))))
+	     ((ref-command write-abbrev-file) #f))
+	 ;; Don't keep bothering user if he says no.
+	 (set! abbrevs-changed? #f)
+	 #t)))
\ No newline at end of file