435 lines
14 KiB
Scheme
435 lines
14 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.
|
||
|
||
|#
|
||
|
||
;;;; Syntax Tables
|
||
|
||
|
||
|
||
(define modify-syntax-entry! set-char-syntax!)
|
||
|
||
(define (modify-syntax-entries! syntax-table cl ch string)
|
||
(set-char-syntax! syntax-table
|
||
(ucs-range->char-set (char->integer cl)
|
||
(char->integer ch))
|
||
string))
|
||
|
||
(define (group-syntax-table-entries group)
|
||
(char-syntax-table/entries (group-syntax-table group)))
|
||
|
||
(define (char-syntax char)
|
||
(char->syntax-code (ref-variable syntax-table) char))
|
||
|
||
(define-command describe-syntax
|
||
"Describe the syntax specifications in the syntax table.
|
||
The descriptions are inserted in a buffer,
|
||
which is selected so you can see it."
|
||
()
|
||
(lambda ()
|
||
(with-output-to-help-display
|
||
(lambda ()
|
||
(newline)
|
||
(let ((table (char-syntax-table/entries (ref-variable syntax-table))))
|
||
(let ((table-end (vector-length table))
|
||
(describe-char-range
|
||
(lambda (bottom top)
|
||
(let ((describe-char
|
||
(lambda (ascii)
|
||
(emacs-key-name (integer->char ascii) #f)))
|
||
(top (- top 1)))
|
||
(if (= bottom top)
|
||
(describe-char bottom)
|
||
(string-append (describe-char bottom)
|
||
" .. "
|
||
(describe-char top)))))))
|
||
(let loop ((start 0))
|
||
(if (< start table-end)
|
||
(let* ((entry (vector-ref table start))
|
||
(end
|
||
(let loop ((index (+ start 1)))
|
||
(if (and (< index table-end)
|
||
(eqv? entry (vector-ref table index)))
|
||
(loop (+ index 1))
|
||
index))))
|
||
(let ((range-desc (describe-char-range start end)))
|
||
(write-string range-desc)
|
||
(write-char #\tab)
|
||
(if (< (string-length range-desc) 8)
|
||
(write-char #\tab)))
|
||
(describe-syntax-entry entry)
|
||
(loop end))))))))))
|
||
|
||
(define (describe-syntax-entry entry)
|
||
(let ((code (fix:and #x0f entry)))
|
||
(if (> code 12)
|
||
(write-string "invalid")
|
||
(begin
|
||
(write-string (char-syntax->string entry))
|
||
(write-string "\twhich means: ")
|
||
(write-string
|
||
(vector-ref '#("whitespace" "punctuation" "word" "symbol" "open"
|
||
"close" "quote" "string" "math"
|
||
"escape" "charquote" "comment"
|
||
"endcomment")
|
||
code))
|
||
(let ((match (fix:and #xff (fix:lsh entry -4))))
|
||
(if (not (zero? match))
|
||
(begin
|
||
(write-string ", matches ")
|
||
(write-string (emacs-key-name (integer->char match) #f)))))
|
||
(let ((decode-comment-bit
|
||
(lambda (code pos se style)
|
||
(if (not (fix:= 0 (fix:and code entry)))
|
||
(begin
|
||
(write-string ",\n\t is the ")
|
||
(write-string pos)
|
||
(write-string " character of comment-")
|
||
(write-string se)
|
||
(write-string " sequence ")
|
||
(write-string style))))))
|
||
(decode-comment-bit #x40000 "first" "start" "B")
|
||
(decode-comment-bit #x10000 "second" "start" "B")
|
||
(decode-comment-bit #x04000 "first" "end" "B")
|
||
(decode-comment-bit #x01000 "second" "end" "B")
|
||
(if (not (and (fix:= code 11)
|
||
(fix:= #x80000 (fix:and #xC0000 entry))))
|
||
(decode-comment-bit #x80000 "first" "start" "A"))
|
||
(decode-comment-bit #x20000 "second" "start" "A")
|
||
(if (not (and (fix:= code 12)
|
||
(fix:= #x08000 (fix:and #x0C000 entry))))
|
||
(decode-comment-bit #x08000 "first" "end" "A"))
|
||
(decode-comment-bit #x02000 "second" "end" "A"))
|
||
(if (not (fix:= 0 (fix:and #x100000 entry)))
|
||
(write-string ",\n\t is a prefix character")))))
|
||
(newline))
|
||
|
||
;;;; Word Parsing
|
||
|
||
(define-variable syntax-table
|
||
"The syntax-table used for word and list parsing."
|
||
(make-char-syntax-table))
|
||
|
||
(define-variable syntax-ignore-comments-backwards
|
||
"If true, ignore comments in backwards expression parsing.
|
||
This can be #T for comments that end in }, as in Pascal or C.
|
||
It should be #F for comments that end in Newline, as in Lisp;
|
||
this is because Newline occurs often when it doesn't indicate
|
||
a comment ending."
|
||
#f
|
||
boolean?)
|
||
|
||
(define forward-word)
|
||
(define backward-word)
|
||
(let ()
|
||
|
||
(define (%forward-word mark n limit?)
|
||
(let ((group (mark-group mark)))
|
||
(let ((end (group-end-index group))
|
||
(entries (group-syntax-table-entries group)))
|
||
(let loop ((start (mark-index mark)) (n n))
|
||
(let ((m
|
||
((ucode-primitive scan-word-forward) entries group start end)))
|
||
(cond ((not m) (limit-mark-motion limit? (make-mark group start)))
|
||
((= n 1) (make-mark group m))
|
||
(else (loop m (-1+ n)))))))))
|
||
|
||
(define (%backward-word mark n limit?)
|
||
(let ((group (mark-group mark)))
|
||
(let ((end (group-start-index group))
|
||
(entries (group-syntax-table-entries group)))
|
||
(let loop ((start (mark-index mark)) (n n))
|
||
(let ((m
|
||
((ucode-primitive scan-word-backward) entries group start end)))
|
||
(cond ((not m) (limit-mark-motion limit? (make-mark group start)))
|
||
((= n 1) (make-mark group m))
|
||
(else (loop m (-1+ n)))))))))
|
||
|
||
(set! forward-word
|
||
(named-lambda (forward-word mark n #!optional limit?)
|
||
(let ((limit? (and (not (default-object? limit?)) limit?)))
|
||
(cond ((positive? n) (%forward-word mark n limit?))
|
||
((negative? n) (%backward-word mark (- n) limit?))
|
||
(else mark)))))
|
||
|
||
(set! backward-word
|
||
(named-lambda (backward-word mark n #!optional limit?)
|
||
(let ((limit? (and (not (default-object? limit?)) limit?)))
|
||
(cond ((positive? n) (%backward-word mark n limit?))
|
||
((negative? n) (%forward-word mark (- n) limit?))
|
||
(else mark)))))
|
||
|
||
)
|
||
|
||
(define (forward-to-word mark #!optional limit?)
|
||
(let ((limit? (and (not (default-object? limit?)) limit?))
|
||
(group (mark-group mark)))
|
||
(let ((index
|
||
((ucode-primitive scan-forward-to-word)
|
||
(group-syntax-table-entries group)
|
||
group
|
||
(mark-index mark)
|
||
(group-end-index group))))
|
||
(if (not index)
|
||
(limit-mark-motion limit? (group-end mark))
|
||
(make-mark group index)))))
|
||
|
||
;;;; Lisp Parsing
|
||
|
||
(define (forward-prefix-chars start #!optional end)
|
||
(let ((group (mark-group start))
|
||
(end (default-end-mark start end)))
|
||
(make-mark group
|
||
((ucode-primitive scan-forward-prefix-chars 4)
|
||
(group-syntax-table-entries group)
|
||
group
|
||
(mark-index start)
|
||
(mark-index end)))))
|
||
|
||
(define (backward-prefix-chars start #!optional end)
|
||
(let ((group (mark-group start))
|
||
(end (default-start-mark end start)))
|
||
(make-mark group
|
||
((ucode-primitive scan-backward-prefix-chars 4)
|
||
(group-syntax-table-entries group)
|
||
group
|
||
(mark-index start)
|
||
(mark-index end)))))
|
||
|
||
(define (mark-right-char-quoted? mark)
|
||
(let ((group (mark-group mark)))
|
||
((ucode-primitive quoted-char?)
|
||
(group-syntax-table-entries group)
|
||
group
|
||
(mark-index mark)
|
||
(group-start-index group))))
|
||
|
||
(define (mark-left-char-quoted? mark)
|
||
(if (group-start? mark)
|
||
(error "Mark has no left char" mark))
|
||
(mark-right-char-quoted? (mark-1+ mark)))
|
||
|
||
(define-structure (parse-state (type vector))
|
||
(depth #f read-only #t)
|
||
(in-string? #f read-only #t) ;#F or ASCII delimiter.
|
||
;; COMMENT-STATE takes the following values:
|
||
;; #f = not in comment
|
||
;; 1 = in comment (style A)
|
||
;; 2 = after first char of two-char comment start (style A)
|
||
;; 3 = after first char of two-char comment end (style A)
|
||
;; 5 = in comment (style B)
|
||
;; 6 = after first char of two-char comment start (style B)
|
||
;; 7 = after first char of two-char comment end (style B)
|
||
;; COMMENT-START is valid when COMMENT-STATE is not #f.
|
||
(comment-state #f read-only #t)
|
||
(quoted? #f read-only #t)
|
||
(start-of-sexp #f)
|
||
(last-sexp #f)
|
||
(containing-sexp #f)
|
||
(location #f)
|
||
(comment-start #f))
|
||
|
||
(define (parse-state-in-comment? state)
|
||
(memv (parse-state-comment-state state) '(1 3 5 7)))
|
||
|
||
(define (in-char-syntax-structure? state)
|
||
(or (parse-state-in-comment? state)
|
||
(parse-state-in-string? state)
|
||
(parse-state-quoted? state)
|
||
(not (= (parse-state-depth state) 0))))
|
||
|
||
(define (parse-state-end-of-sexp state)
|
||
(cond ((parse-state-start-of-sexp state)
|
||
=> forward-one-sexp)
|
||
(else #f)))
|
||
|
||
(define (forward-to-sexp-start mark end)
|
||
(parse-state-location (parse-partial-sexp mark end 0 #t)))
|
||
|
||
(define (parse-partial-sexp start end
|
||
#!optional target-depth stop-before? old-state)
|
||
(if (not (mark<= start end))
|
||
(error "Marks incorrectly related:" start end))
|
||
(let ((target-depth
|
||
(if (or (default-object? target-depth) (not target-depth))
|
||
-1000000
|
||
target-depth))
|
||
(stop-before? (if (default-object? stop-before?) #f stop-before?))
|
||
(old-state (if (default-object? old-state) #f old-state))
|
||
(group (mark-group start)))
|
||
(let ((state
|
||
((ucode-primitive scan-sexps-forward)
|
||
(group-syntax-table-entries group)
|
||
group
|
||
(mark-index start)
|
||
(mark-index end)
|
||
target-depth stop-before? old-state)))
|
||
;; Convert the returned indices to marks.
|
||
(if (parse-state-start-of-sexp state)
|
||
(set-parse-state-start-of-sexp!
|
||
state
|
||
(make-mark group (parse-state-start-of-sexp state))))
|
||
(if (parse-state-last-sexp state)
|
||
(set-parse-state-last-sexp!
|
||
state
|
||
(make-mark group (parse-state-last-sexp state))))
|
||
(if (parse-state-containing-sexp state)
|
||
(set-parse-state-containing-sexp!
|
||
state
|
||
(make-mark group (parse-state-containing-sexp state))))
|
||
(set-parse-state-location! state
|
||
(make-mark group
|
||
(parse-state-location state)))
|
||
(if (parse-state-comment-start state)
|
||
(set-parse-state-comment-start!
|
||
state
|
||
(make-mark group (parse-state-comment-start state))))
|
||
state)))
|
||
|
||
(define forward-one-sexp)
|
||
(define backward-one-sexp)
|
||
(define forward-one-list)
|
||
(define backward-one-list)
|
||
(define forward-up-one-list)
|
||
(define backward-up-one-list)
|
||
(define forward-down-one-list)
|
||
(define backward-down-one-list)
|
||
(let ()
|
||
|
||
(define (%forward-list start end depth sexp?)
|
||
(let ((group (mark-group start)))
|
||
(let ((index
|
||
((ucode-primitive scan-list-forward)
|
||
(group-syntax-table-entries group)
|
||
group
|
||
(mark-index start)
|
||
(mark-index end)
|
||
depth
|
||
sexp?
|
||
#t)))
|
||
(and index (make-mark group index)))))
|
||
|
||
(define (%backward-list start end depth sexp?)
|
||
(let ((group (mark-group start)))
|
||
(let ((index
|
||
((ucode-primitive scan-list-backward)
|
||
(group-syntax-table-entries group)
|
||
group
|
||
(mark-index start)
|
||
(mark-index end)
|
||
depth
|
||
sexp?
|
||
(group-local-ref
|
||
group
|
||
(ref-variable-object syntax-ignore-comments-backwards)))))
|
||
(and index (make-mark group index)))))
|
||
|
||
(set! forward-one-sexp
|
||
(named-lambda (forward-one-sexp start #!optional end)
|
||
(%forward-list start (default-end-mark start end) 0 #t)))
|
||
|
||
(set! backward-one-sexp
|
||
(named-lambda (backward-one-sexp start #!optional end)
|
||
(let ((end (default-start-mark end start)))
|
||
(let ((mark (%backward-list start end 0 #t)))
|
||
(and mark (backward-prefix-chars mark end))))))
|
||
|
||
(set! forward-one-list
|
||
(named-lambda (forward-one-list start #!optional end)
|
||
(%forward-list start (default-end-mark start end) 0 #f)))
|
||
|
||
(set! backward-one-list
|
||
(named-lambda (backward-one-list start #!optional end)
|
||
(%backward-list start (default-start-mark end start) 0 #f)))
|
||
|
||
(set! forward-up-one-list
|
||
(named-lambda (forward-up-one-list start #!optional end)
|
||
(%forward-list start (default-end-mark start end) 1 #f)))
|
||
|
||
(set! backward-up-one-list
|
||
(named-lambda (backward-up-one-list start #!optional end)
|
||
(%backward-list start (default-start-mark end start) 1 #f)))
|
||
|
||
(set! forward-down-one-list
|
||
(named-lambda (forward-down-one-list start #!optional end)
|
||
(%forward-list start (default-end-mark start end) -1 #f)))
|
||
|
||
(set! backward-down-one-list
|
||
(named-lambda (backward-down-one-list start #!optional end)
|
||
(%backward-list start (default-start-mark end start) -1 #f)))
|
||
|
||
)
|
||
|
||
;;;; Definition Start/End
|
||
|
||
(define-variable definition-start
|
||
"Regexp to match start of a definition."
|
||
"^\\s("
|
||
string?)
|
||
|
||
(define (definition-start? mark)
|
||
(re-match-forward
|
||
(mark-local-ref mark (ref-variable-object definition-start))
|
||
mark))
|
||
|
||
(define (forward-one-definition-start mark)
|
||
(and (re-search-forward
|
||
(mark-local-ref mark (ref-variable-object definition-start))
|
||
(if (line-start? mark) (line-end mark 0) mark)
|
||
(group-end mark))
|
||
(re-match-start 0)))
|
||
|
||
(define (backward-one-definition-start mark)
|
||
(re-search-backward
|
||
(mark-local-ref mark (ref-variable-object definition-start))
|
||
mark
|
||
(group-start mark)))
|
||
|
||
(define (forward-one-definition-end mark)
|
||
(define (loop start)
|
||
(and start
|
||
(let ((end (forward-one-list start)))
|
||
(and end
|
||
(let ((end*
|
||
(let ((end (horizontal-space-end end)))
|
||
(if (re-match-forward "[;\n]" end)
|
||
(line-start end 1 'LIMIT)
|
||
end))))
|
||
(if (mark> end* mark)
|
||
end*
|
||
(loop (forward-one-definition-start end))))))))
|
||
(and (not (group-end? mark))
|
||
(loop (or (backward-one-definition-start (mark1+ mark))
|
||
(forward-one-definition-start (group-start mark))))))
|
||
|
||
(define (backward-one-definition-end mark)
|
||
(let ((start (backward-one-definition-start mark)))
|
||
(and start
|
||
(let ((end (forward-one-definition-end start)))
|
||
(and end
|
||
(if (mark< end mark)
|
||
end
|
||
(let ((start (backward-one-definition-start start)))
|
||
(and start (forward-one-definition-end start)))))))))
|