281 lines
9.8 KiB
Scheme
281 lines
9.8 KiB
Scheme
#| -*-Scheme-*-
|
||
|
||
Copyright (C) 1986, 1987, 1988, 1989, 1990, 1991, 1992, 1993, 1994,
|
||
1995, 1996, 1997, 1998, 1999, 2000, 2001, 2002, 2003, 2004, 2005,
|
||
2006, 2007, 2008, 2009, 2010, 2011, 2012, 2013, 2014, 2015, 2016,
|
||
2017, 2018, 2019, 2020 Massachusetts Institute of Technology
|
||
|
||
This file is part of MIT/GNU Scheme.
|
||
|
||
MIT/GNU Scheme 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.
|
||
|
||
MIT/GNU Scheme 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 MIT/GNU Scheme; if not, write to the Free Software
|
||
Foundation, Inc., 51 Franklin St, Fifth Floor, Boston, MA 02110-1301,
|
||
USA.
|
||
|
||
|#
|
||
|
||
;;;; Occurrence Commands
|
||
|
||
|
||
|
||
(define-command keep-lines
|
||
"Delete all lines except those containing matches for REGEXP.
|
||
A match split across lines preserves all the lines it lies in.
|
||
Applies to all lines after point."
|
||
"sKeep lines (containing match for regexp)"
|
||
(lambda (regexp)
|
||
(let ((point (current-point)))
|
||
(keep-lines point (group-end point) regexp))))
|
||
|
||
(define-command delete-non-matching-lines
|
||
(command-description (ref-command-object keep-lines))
|
||
(command-interactive-specification (ref-command-object keep-lines))
|
||
(command-procedure (ref-command-object keep-lines)))
|
||
|
||
(define (keep-lines start end regexp)
|
||
(let ((pattern
|
||
(re-compile-pattern regexp (ref-variable case-fold-search start)))
|
||
(syntax-table (ref-variable syntax-table start))
|
||
(group (mark-group start))
|
||
(start (mark-index start))
|
||
(anchor (mark-left-inserting-copy start))
|
||
(end (mark-left-inserting-copy end)))
|
||
(define (loop start point)
|
||
(let ((point
|
||
(re-search-buffer-forward pattern syntax-table
|
||
group point (mark-index end))))
|
||
(if point
|
||
(begin
|
||
(set-mark-index! anchor point)
|
||
(let ((end
|
||
(line-start-index group (re-match-start-index 0))))
|
||
(if (< start end)
|
||
(group-delete! group start end)))
|
||
(continue (mark-index anchor)))
|
||
(group-delete! group start (mark-index end)))))
|
||
(define (continue point)
|
||
(let ((start (line-end-index group point)))
|
||
(if (< start (mark-index end))
|
||
(loop (+ start 1) point))))
|
||
(if (line-start-index? group start)
|
||
(loop start start)
|
||
(continue start))
|
||
(mark-temporary! anchor)
|
||
(mark-temporary! end)))
|
||
|
||
(define-command flush-lines
|
||
"Delete lines containing matches for REGEXP.
|
||
If a match is split across lines, all the lines it lies in are deleted.
|
||
Applies to lines after point."
|
||
"sFlush lines (containing match for regexp)"
|
||
(lambda (regexp)
|
||
(let ((point (current-point)))
|
||
(flush-lines point (group-end point) regexp))))
|
||
|
||
(define-command delete-matching-lines
|
||
(command-description (ref-command-object flush-lines))
|
||
(command-interactive-specification (ref-command-object flush-lines))
|
||
(command-procedure (ref-command-object flush-lines)))
|
||
|
||
(define (flush-lines start end regexp)
|
||
(let ((pattern
|
||
(re-compile-pattern regexp (ref-variable case-fold-search start)))
|
||
(syntax-table (ref-variable syntax-table start))
|
||
(group (mark-group start))
|
||
(start (mark-left-inserting-copy start))
|
||
(end (mark-left-inserting-copy end)))
|
||
(do ()
|
||
((not (re-search-buffer-forward pattern
|
||
syntax-table
|
||
group
|
||
(mark-index start)
|
||
(mark-index end))))
|
||
(let ((point (line-end-index group (re-match-end-index 0))))
|
||
(set-mark-index! start point)
|
||
(group-delete! group
|
||
(line-start-index group (re-match-start-index 0))
|
||
(if (< point (mark-index end)) (+ point 1) point))))
|
||
(mark-temporary! start)
|
||
(mark-temporary! end)))
|
||
|
||
(define-command count-matches
|
||
"Print number of matches for REGEXP following point."
|
||
"sCount matches for (regexp)"
|
||
(lambda (regexp)
|
||
(message (let ((point (current-point)))
|
||
(count-matches point (group-end point) regexp))
|
||
" occurrences")))
|
||
|
||
(define-command how-many
|
||
(command-description (ref-command-object count-matches))
|
||
(command-interactive-specification (ref-command-object count-matches))
|
||
(command-procedure (ref-command-object count-matches)))
|
||
|
||
(define (count-matches start end regexp)
|
||
(let ((pattern
|
||
(re-compile-pattern regexp (ref-variable case-fold-search start)))
|
||
(syntax-table (ref-variable syntax-table start))
|
||
(group (mark-group start))
|
||
(end (mark-index end)))
|
||
(let loop ((start (mark-index start)) (result 0))
|
||
(let ((match
|
||
(re-search-buffer-forward pattern syntax-table group start end)))
|
||
(if match
|
||
(loop match (+ result 1))
|
||
result)))))
|
||
|
||
(define-major-mode occur fundamental "Occur"
|
||
"Major mode for output from \\[occur].
|
||
Move point to one of the occurrences in this buffer,
|
||
then use \\[occur-mode-goto-occurrence] to go to the same occurrence
|
||
in the buffer that the occurrences were found in.")
|
||
|
||
(define-key 'occur '(#\c-c #\c-c) 'occur-mode-goto-occurrence)
|
||
|
||
(define-command occur-mode-goto-occurrence
|
||
"Go to the line this occurrence was found in, in the buffer it was found in."
|
||
()
|
||
(lambda ()
|
||
(let ((mark
|
||
(let ((point (current-point)))
|
||
(let ((r (region-get point 'OCCURRENCE #f)))
|
||
(if (not r)
|
||
(editor-error "No occurrence selected."))
|
||
(region-start r)))))
|
||
(let ((buffer (mark-buffer mark)))
|
||
(if (not (buffer-alive? buffer))
|
||
(editor-error "Buffer in which occurences were found is deleted."))
|
||
(pop-up-buffer buffer #t)
|
||
(set-buffer-point! buffer mark)))))
|
||
|
||
(define-variable list-matching-lines-default-context-lines
|
||
"Default number of context lines to include around a list-matching-lines
|
||
match. A negative number means to include that many lines before the match.
|
||
A positive number means to include that many lines both before and after."
|
||
0
|
||
exact-integer?)
|
||
|
||
(define-command occur
|
||
"Show all lines following point containing a match for REGEXP.
|
||
Display each line with NLINES lines before and after,
|
||
or -NLINES before if NLINES is negative.
|
||
NLINES defaults to list-matching-lines-default-context-lines.
|
||
Interactively it is the prefix arg.
|
||
|
||
The lines are shown in a buffer named *Occur*.
|
||
It serves as a menu to find any of the occurrences in this buffer.
|
||
\\[describe-mode] in that buffer will explain how."
|
||
"sList lines matching regexp\nP"
|
||
(lambda (regexp argument)
|
||
(pop-up-occur-buffer (current-point)
|
||
(buffer-end (selected-buffer))
|
||
regexp
|
||
(and argument
|
||
(command-argument-numeric-value argument)))))
|
||
|
||
(define-command list-matching-lines
|
||
(command-description (ref-command-object occur))
|
||
(command-interactive-specification (ref-command-object occur))
|
||
(command-procedure (ref-command-object occur)))
|
||
|
||
(define (pop-up-occur-buffer start end regexp nlines)
|
||
(let ((occurrences (re-occurrences start end regexp))
|
||
(occur-buffer (temporary-buffer "*Occur*")))
|
||
(let ((output (mark-left-inserting-copy (buffer-start occur-buffer))))
|
||
(insert-string (write-to-string (length occurrences)) output)
|
||
(insert-string " lines matching " output)
|
||
(insert-string (write-to-string regexp) output)
|
||
(insert-string " in buffer " output)
|
||
(insert-string (buffer-name (mark-buffer start)) output)
|
||
(insert-string ".\n" output)
|
||
(set-buffer-major-mode! occur-buffer (ref-mode-object occur))
|
||
(format-occurrences occurrences
|
||
(or nlines
|
||
(ref-variable
|
||
list-matching-lines-default-context-lines
|
||
start))
|
||
output)
|
||
(mark-temporary! output))
|
||
(set-buffer-point! occur-buffer (buffer-start occur-buffer))
|
||
(pop-up-buffer occur-buffer #f)))
|
||
|
||
(define (re-occurrences start end regexp)
|
||
(let ((pattern
|
||
(re-compile-pattern regexp (ref-variable case-fold-search start)))
|
||
(syntax-table (ref-variable syntax-table start))
|
||
(group (mark-group start))
|
||
(end (mark-index end)))
|
||
(let loop ((start (mark-index start)) (occurrences '()))
|
||
(let ((match
|
||
(re-search-buffer-forward pattern syntax-table group start end)))
|
||
(if match
|
||
(loop (line-end-index group (re-match-end-index 0))
|
||
(cons (make-region (mark-right-inserting (re-match-start 0))
|
||
(mark-left-inserting (re-match-end 0)))
|
||
occurrences))
|
||
(reverse! occurrences))))))
|
||
|
||
(define (format-occurrences occurrences nlines output)
|
||
(if (pair? occurrences)
|
||
(let loop
|
||
((occurrences occurrences)
|
||
(prev-ls #f)
|
||
(line 1))
|
||
(let ((r (car occurrences))
|
||
(m (mark-right-inserting-copy output)))
|
||
(let ((ls (line-start (region-start r) 0)))
|
||
(let ((line
|
||
(+ line (count-lines (or prev-ls (group-start ls)) ls))))
|
||
(format-occurrence ls (line-start (region-end r) 0)
|
||
line nlines
|
||
output)
|
||
(region-put! m output 'OCCURRENCE r)
|
||
(if (pair? (cdr occurrences))
|
||
(begin
|
||
(if (not (= nlines 0))
|
||
(insert-string "--------\n" output))
|
||
(loop (cdr occurrences) ls line)))))))))
|
||
|
||
(define (format-occurrence rs re line nlines output)
|
||
(let ((empty " "))
|
||
(if (not (= nlines 0))
|
||
(let loop ((ls (line-start rs (- (abs nlines)) 'LIMIT)))
|
||
(if (mark< ls rs)
|
||
(let ((ls* (line-start ls 1 'ERROR)))
|
||
(insert-string empty output)
|
||
(insert-string ":" output)
|
||
(insert-region ls ls* output)
|
||
(loop ls*)))))
|
||
(let loop ((ls rs))
|
||
(let ((le (line-end ls 0)))
|
||
(insert-string (if (mark= ls rs)
|
||
(pad-on-left-to (number->string line) 7)
|
||
empty)
|
||
output)
|
||
(insert-string ":" output)
|
||
(insert-region ls le output)
|
||
(insert-newline output)
|
||
(if (mark< le re)
|
||
(loop (line-start ls 1 'LIMIT)))))
|
||
(if (> nlines 0)
|
||
(let ((ls (line-start rs 1 #f)))
|
||
(if ls
|
||
(let loop ((ls ls) (n nlines))
|
||
(let ((le (line-end ls 0)))
|
||
(insert-string empty output)
|
||
(insert-string ":" output)
|
||
(insert-region ls le output)
|
||
(insert-newline output)
|
||
(if (and (not (group-end? le)) (> n 1))
|
||
(loop (mark1+ le) (- n 1))))))))))
|