From: Chris Hanson Date: Tue, 17 Nov 1992 22:41:06 +0000 (+0000) Subject: Initial revision X-Git-Tag: 20090517-FFI~8757 X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=4480dc33bedad4929b95307fba4c512dbed2eb54;p=mit-scheme.git Initial revision --- diff --git a/v7/src/edwin/dabbrev.scm b/v7/src/edwin/dabbrev.scm new file mode 100644 index 000000000..94d6454c8 --- /dev/null +++ b/v7/src/edwin/dabbrev.scm @@ -0,0 +1,265 @@ +;;; -*-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)) + +(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") + +(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)))) + +;; 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