--- /dev/null
+;;; -*-Scheme-*-
+;;;
+;;; $Id: dabbrev.scm,v 1.1 1992/11/17 22:41:06 cph Exp $
+;;;
+;;; Copyright (c) 1992 Massachusetts Institute of Technology
+;;;
+;;; This material was developed by the Scheme project at the
+;;; Massachusetts Institute of Technology, Department of
+;;; Electrical Engineering and Computer Science. Permission to
+;;; copy this software, to redistribute it, and to use it for any
+;;; purpose is granted, subject to the following restrictions and
+;;; understandings.
+;;;
+;;; 1. Any copy made of this software must include this copyright
+;;; notice in full.
+;;;
+;;; 2. Users of this software agree to make their best efforts (a)
+;;; to return to the MIT Scheme project any improvements or
+;;; extensions that they make, so that these may be included in
+;;; future releases; and (b) to inform MIT of noteworthy uses of
+;;; this software.
+;;;
+;;; 3. All materials developed as a consequence of the use of this
+;;; software shall duly acknowledge such use, in accordance with
+;;; the usual standards of acknowledging credit in academic
+;;; research.
+;;;
+;;; 4. MIT has made no warrantee or representation that the
+;;; operation of this software will be error-free, and MIT is
+;;; under no obligation to provide any services, by way of
+;;; maintenance, update, or otherwise.
+;;;
+;;; 5. In conjunction with products arising from the use of this
+;;; material, there shall be no use of the name of the
+;;; Massachusetts Institute of Technology nor of any adaptation
+;;; thereof in any advertising, promotional, or sales literature
+;;; without prior written consent from MIT in each case.
+;;;
+;;; NOTE: Parts of this program (Edwin) were created by translation
+;;; from corresponding parts of GNU Emacs. Users should be aware that
+;;; the GNU GENERAL PUBLIC LICENSE may apply to these parts. A copy
+;;; of that license should have been included along with this file.
+;;;
+
+;;;; Dynamic Abbrev
+
+(declare (usual-integrations))
+\f
+(define-variable dabbrevs-backward-only
+ "If true, dabbrevs-expand only looks backwards."
+ false
+ boolean?)
+
+(define-variable-per-buffer dabbrevs-limit
+ "Limits region searched by dabbrevs-expand to that many chars away (local)."
+ false
+ (lambda (object)
+ (or (not object)
+ (exact-integer? object))))
+
+(define-variable-per-buffer last-dabbrev-table
+ "Table of expansions seen so far (local)."
+ '())
+
+(define-variable-per-buffer last-dabbrevs-abbreviation
+ "Last string we tried to expand (local)."
+ ""
+ string?)
+
+(define-variable-per-buffer last-dabbrevs-direction
+ "Direction of last dabbrevs search (local)."
+ 0
+ exact-integer?)
+
+(define-variable-per-buffer last-dabbrevs-abbrev-location
+ "Location last abbreviation began (local)."
+ false)
+
+(define-variable-per-buffer last-dabbrevs-expansion
+ "Last expansion of an abbreviation (local)."
+ false)
+
+(define-variable-per-buffer last-dabbrevs-expansion-location
+ "Location the last expansion was found (local)."
+ false)
+
+(define dabbrev-tag "Dabbrev")
+\f
+(define-command dabbrev-expand
+ "Expand previous word \"dynamically\".
+Expands to the most recent, preceding word for which this is a prefix.
+If no suitable preceding word is found, words following point are considered.
+
+A positive prefix argument, N, says to take the Nth backward DISTINCT
+possibility. A negative argument says search forward. The variable
+dabbrev-backward-only may be used to limit the direction of search to
+backward if set non-nil.
+
+If the cursor has not moved from the end of the previous expansion and
+no argument is given, replace the previously-made expansion
+with the next possible expansion not yet tried."
+ "*P"
+ (lambda (arg)
+ (define (do-abbrev loc abbrev old which)
+ (let ((do-case (and (ref-variable case-fold-search)
+ (ref-variable case-replace)))
+ (pattern (string-append "\\b"
+ (re-quote-string abbrev)
+ "\\(\\sw\\|\\s_\\)+")))
+
+ (define (search&setup-table count direction)
+ (let loop ((n count)
+ (expansion false)
+ (start
+ (or (ref-variable last-dabbrevs-expansion-location)
+ (current-point))))
+ (if (zero? n)
+ (values (mark-permanent-copy start) expansion)
+ (with-values
+ (lambda ()
+ (dabbrevs-search start pattern direction do-case))
+ (lambda (loc expansion)
+ (if (not expansion)
+ (values false false)
+ (begin
+ (set-variable!
+ last-dabbrev-table
+ (cons expansion
+ (ref-variable last-dabbrev-table)))
+ (loop (-1+ n) expansion loc))))))))
+
+ (define (step3 loc expansion)
+ (if (not expansion)
+ (let ((first (string=? abbrev old)))
+ (set-variable! last-dabbrevs-abbrev-location false)
+ (if (not first)
+ (let* ((end (current-point))
+ (start (mark- end (string-length old))))
+ (delete-string start end)
+ (insert-string abbrev start)))
+ (editor-error (if first
+ "No dynamic expansion found for "
+ "No further dynamic expansions found for ")
+ abbrev))
+ ;; Success: stick it in and return.
+ ;; Make case of replacement conform to case of abbreviation
+ ;; provided (1) that kind of thing is enabled in this buffer
+ ;; and (2) the replacement itself is all lower case
+ ;; except perhaps for the first character.
+ (let ((place (search-backward old
+ (current-point)
+ (buffer-start (current-buffer))))
+ (do-case (and do-case
+ (char=? (string-ref expansion 0)
+ (char-downcase
+ (string-ref expansion 0))))))
+ ;; First put back the original abbreviation with its original
+ ;; case pattern.
+ (replace-match abbrev true true)
+ (search-forward abbrev
+ place
+ (buffer-end (current-buffer)))
+ (replace-match (if do-case
+ (string-downcase expansion)
+ expansion)
+ (not do-case)
+ true)
+ ;; Save state for re-expand.
+ (set-variable! last-dabbrevs-abbreviation abbrev)
+ (set-variable! last-dabbrevs-expansion expansion)
+ (set-variable! last-dabbrevs-expansion-location loc)
+ ;; Chain invocations
+ (set-command-message! dabbrev-tag))))
+
+ (define (step2 loc expansion)
+ (if (or expansion (> which 0))
+ (step3 loc expansion)
+ ;; Look forward
+ (with-values (lambda ()
+ (search&setup-table (max 1 (- which)) false))
+ (lambda (loc expansion)
+ (set-variable! last-dabbrevs-direction -1)
+ (step3 loc expansion)))))
+
+ ;; Try looking backward unless inhibited.
+ (if (< which 0)
+ (step2 loc false)
+ (with-values (lambda ()
+ (search&setup-table (max 1 which) true))
+ (lambda (loc expansion)
+ (if (not expansion)
+ (set-variable! last-dabbrevs-expansion-location
+ false))
+ (set-variable! last-dabbrevs-direction (min 1 which))
+ (step2 loc expansion))))))
+
+ (define (do-from-scratch)
+ (let* ((loc (current-point))
+ (start (backward-word loc 1 'ERROR))
+ (abbrev (extract-string start loc)))
+ (set-variable! last-dabbrevs-abbrev-location start)
+ (set-variable! last-dabbrevs-expansion-location false)
+ (set-variable! last-dabbrev-table '())
+ (do-abbrev loc
+ abbrev
+ abbrev
+ (cond (arg
+ (command-argument-value arg))
+ ((ref-variable dabbrevs-backward-only)
+ 1)
+ (else
+ 0)))))
+
+ (if (and (not arg)
+ (command-message-receive dabbrev-tag
+ (lambda () true)
+ (lambda () false))
+ (ref-variable last-dabbrevs-abbrev-location))
+ (do-abbrev false
+ (ref-variable last-dabbrevs-abbreviation)
+ (ref-variable last-dabbrevs-expansion)
+ (ref-variable last-dabbrevs-direction))
+ (do-from-scratch))))
+\f
+;; Search function used by dabbrevs library.
+;; pattern is string to find as prefix of word.
+;; reverse? is true for reverse search, false for forward.
+;; Variable abbrevs-limit controls the maximum search region size.
+
+;; Table of expansions already seen is examined in buffer last-dabbrev-table,
+;; so that only distinct possibilities are found by dabbrevs-re-expand.
+;; Note that to prevent finding the abbrev itself it must have been
+;; entered in the table.
+
+;; Values are false if no expansion found.
+;; After a succesful search, values are a mark right after the expansion,
+;; and the expansion itself.
+
+(define (dabbrevs-search start pattern reverse? do-case)
+ ;; (values loc expansion)
+ (let ((limit (let ((limit (ref-variable dabbrevs-limit)))
+ (if limit
+ ((if reverse? mark- mark+)
+ start
+ limit)
+ ((if reverse? buffer-start buffer-end)
+ (current-buffer))))))
+ (let loop ((posn start))
+ (if (not ((if reverse? re-search-backward re-search-forward)
+ pattern posn limit))
+ (values false false)
+ (let ((start (re-match-start 0))
+ (end (re-match-end 0)))
+ (let* ((result (extract-string start end))
+ (test (if do-case
+ (string-downcase result)
+ result)))
+ (if (there-exists? (ref-variable last-dabbrev-table)
+ (lambda (example)
+ (string=? test
+ (if do-case
+ (string-downcase example)
+ example))))
+ (loop (if reverse? start end))
+ (values end result))))))))
\ No newline at end of file
projects / mit-scheme.git / commitdiff