417 lines
15 KiB
Scheme
417 lines
15 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.
|
||
|
||
|#
|
||
|
||
;;;; C Indentation (from GNU Emacs)
|
||
|
||
|
||
|
||
(define-variable c-indent-level
|
||
"Indentation of C statements with respect to containing block."
|
||
2
|
||
exact-integer?)
|
||
|
||
(define-variable c-brace-imaginary-offset
|
||
"Imagined indentation of a C open brace that actually follows a statement."
|
||
0
|
||
exact-integer?)
|
||
|
||
(define-variable c-brace-offset
|
||
"Extra indentation for braces, compared with other text in same context."
|
||
0
|
||
exact-integer?)
|
||
|
||
(define-variable c-argdecl-indent
|
||
"Indentation level of declarations of C function arguments."
|
||
5
|
||
exact-integer?)
|
||
|
||
(define-variable c-label-offset
|
||
"Offset of C label lines and case statements relative to usual indentation."
|
||
-2
|
||
exact-integer?)
|
||
|
||
(define-variable c-continued-statement-offset
|
||
"Extra indent for lines not starting new statements."
|
||
2
|
||
exact-integer?)
|
||
|
||
(define-variable c-continued-brace-offset
|
||
"Extra indent for substatements that start with open-braces.
|
||
This is in addition to c-continued-statement-offset."
|
||
0
|
||
exact-integer?)
|
||
|
||
(define (c-indent-line start)
|
||
(let ((old-indentation (mark-indentation start))
|
||
(new-indentation (c-compute-indentation start)))
|
||
(if (not (fix:= new-indentation old-indentation))
|
||
(change-indentation new-indentation start))
|
||
(- new-indentation old-indentation)))
|
||
|
||
(define (c-compute-indentation start)
|
||
(let ((start (line-start start 0)))
|
||
(let ((indentation (calculate-indentation start #f)))
|
||
(if (exact-integer? indentation)
|
||
(if (char-match-forward #\# start)
|
||
0
|
||
(indent-line:adjust-indentation (horizontal-space-end start)
|
||
indentation))
|
||
(nonstandard-indentation start indentation)))))
|
||
|
||
(define (nonstandard-indentation start state)
|
||
(cond ((parse-state-in-string? state)
|
||
(mark-indentation start))
|
||
((parse-state-in-comment? state)
|
||
(mark-column
|
||
(let ((comment-start (parse-state-comment-start state)))
|
||
(if (and (char-match-forward #\* (indentation-end start))
|
||
(match-forward "/*" comment-start))
|
||
(mark1+ comment-start)
|
||
(or (re-match-forward "/\\(/+\\|\\*+\\)[ \t]*"
|
||
comment-start)
|
||
comment-start)))))
|
||
(else
|
||
(error "Illegal non-standard indentation:" state))))
|
||
|
||
(define (indent-line:adjust-indentation start indentation)
|
||
(cond ((or (looking-at-keyword? "case" start)
|
||
(and (re-match-forward "[A-Za-z]" start)
|
||
(char-match-forward #\: (forward-sexp start 1 'LIMIT))))
|
||
(max 1 (+ indentation (ref-variable c-label-offset start))))
|
||
((looking-at-keyword? "else" start)
|
||
(mark-indentation
|
||
(backward-to-start-of-if
|
||
start
|
||
(backward-definition-start start 1 'LIMIT))))
|
||
((char-match-forward #\} start)
|
||
(max 0 (- indentation (ref-variable c-indent-level start))))
|
||
((char-match-forward #\{ start)
|
||
(max 0 (+ indentation (ref-variable c-brace-offset start))))
|
||
(else (max 0 indentation))))
|
||
|
||
(define (calculate-indentation mark parse-start)
|
||
(let ((indent-point (line-start mark 0)))
|
||
(let ((state
|
||
(let loop
|
||
((start
|
||
(or parse-start (backward-definition-start mark 1 'LIMIT))))
|
||
(let ((state (parse-partial-sexp start indent-point 0)))
|
||
(if (mark= (parse-state-location state) indent-point)
|
||
state
|
||
(loop (parse-state-location state)))))))
|
||
(let ((container (parse-state-containing-sexp state)))
|
||
(cond ((or (parse-state-in-string? state)
|
||
(parse-state-in-comment? state))
|
||
state)
|
||
((not container)
|
||
(calculate-indentation:top-level indent-point
|
||
(or parse-start
|
||
(group-start mark))))
|
||
((char-match-forward #\{ container)
|
||
(calculate-indentation:statement indent-point container))
|
||
(else
|
||
;; Line is expression, not statement: indent to just
|
||
;; after the surrounding open.
|
||
(mark-column (mark1+ container))))))))
|
||
|
||
(define (calculate-indentation:top-level indent-point parse-start)
|
||
(if (or (re-match-forward "[ \t]*{" indent-point)
|
||
(function-start? indent-point parse-start))
|
||
;; This appears to be the start of a function or a function
|
||
;; body, so indent in the left-hand column.
|
||
0
|
||
(let ((m (backward-to-noncomment indent-point parse-start)))
|
||
(if (or (not m) (not (extract-left-char m)))
|
||
;; This appears to be the beginning of a top-level data
|
||
;; definition, so indent in the left-hand column.
|
||
0
|
||
;; Look at the previous left-justified line to determine
|
||
;; if we're in a data definition or a function preamble.
|
||
(let ((m (re-search-backward "^[^ \t\n\f#]" m)))
|
||
(if (not m)
|
||
0
|
||
(let ((m (function-start? m parse-start)))
|
||
(if (and m (mark< m indent-point))
|
||
;; Previous line is a function start and we're
|
||
;; indenting a line that follows the parameter
|
||
;; list and precedes the body, so indent it as
|
||
;; a parameter declaration.
|
||
(ref-variable c-argdecl-indent indent-point)
|
||
0))))))))
|
||
|
||
(define (function-start? lstart parse-start)
|
||
;; True iff LSTART points at the beginning of a function definition.
|
||
;; If true, returns a mark pointing to the end of the function's
|
||
;; parameter list.
|
||
(and (re-match-forward "\\sw\\|\\s_" lstart)
|
||
(re-match-forward "[^\"\n=(]*(" lstart)
|
||
(let ((open (mark-1+ (re-match-end 0))))
|
||
;; OPEN looks like the start of a parameter list. If it
|
||
;; doesn't end in comma or semicolon, and furthermore isn't
|
||
;; in a comment, we conclude that it is a parameter list, and
|
||
;; consequently that we're looking at a function.
|
||
(and (not (parse-state-in-comment?
|
||
(parse-partial-sexp parse-start open)))
|
||
(let ((m (forward-sexp open 1)))
|
||
(and m
|
||
(let ((m (skip-chars-forward " \t\f" m)))
|
||
(and (not (re-match-forward "[,;]" m))
|
||
m))))))))
|
||
|
||
(define (calculate-indentation:statement indent-point container)
|
||
(let ((mark
|
||
(let loop ((start indent-point))
|
||
(let ((m (backward-to-noncomment start container)))
|
||
;; Back up over label lines, since they don't affect
|
||
;; whether our line is a continuation.
|
||
(case (and m (mark> m container) (extract-left-char m))
|
||
((#\:)
|
||
(if (let ((m (backward-to-noncomment (mark-1+ m) container)))
|
||
(and m
|
||
(mark> m container)
|
||
(re-match-forward "'\\|\\sw\\|\\s_" (mark-1+ m))))
|
||
(loop (line-start m 0))
|
||
m))
|
||
((#\,)
|
||
(let ((ls (line-start m 0)))
|
||
(if (mark<= ls container)
|
||
#f
|
||
(loop (horizontal-space-end ls)))))
|
||
(else m))))))
|
||
(if (and mark (not (memv (extract-left-char mark) '(#F #\, #\; #\{ #\}))))
|
||
;; This line is continuation of preceding line's statement;
|
||
;; indent c-continued-statement-offset more than the previous
|
||
;; line of the statement.
|
||
(+ (ref-variable c-continued-statement-offset indent-point)
|
||
(mark-column (backward-to-start-of-continued-exp mark container))
|
||
(if (re-match-forward "[ \t]*{" indent-point)
|
||
(ref-variable c-continued-brace-offset indent-point)
|
||
0))
|
||
(or (skip-comments&labels (mark1+ container) indent-point)
|
||
;; If no previous statement, indent it relative to line
|
||
;; brace is on. For open brace in column zero, don't let
|
||
;; statement start there too. If c-indent-level is zero,
|
||
;; use c-brace-offset + c-continued-statement-offset
|
||
;; instead. For open-braces not the first thing in a
|
||
;; line, add in c-brace-imaginary-offset.
|
||
(+ (if (and (line-start? container)
|
||
(= 0 (ref-variable c-indent-level indent-point)))
|
||
(+ (ref-variable c-brace-offset indent-point)
|
||
(ref-variable c-continued-statement-offset indent-point))
|
||
(ref-variable c-indent-level indent-point))
|
||
(let ((container (skip-chars-backward " \t" container)))
|
||
;; If open brace is not the first non-white thing on
|
||
;; the line, add the c-brace-imaginary-offset.
|
||
(+ (if (line-start? container)
|
||
0
|
||
(ref-variable c-brace-imaginary-offset indent-point))
|
||
(mark-indentation
|
||
;; If the open brace is preceded by a
|
||
;; parenthesized expression, move to the
|
||
;; beginning of that; possibly a different line.
|
||
(if (eqv? #\) (extract-left-char container))
|
||
(backward-sexp container 1 'LIMIT)
|
||
container)))))))))
|
||
|
||
(define (skip-comments&labels start end)
|
||
(let ((gend (group-end start)))
|
||
(let loop ((mark start) (colon-line-end false))
|
||
(let ((mark (whitespace-end mark gend)))
|
||
(cond ((mark>= mark end)
|
||
false)
|
||
((or (char-match-forward #\# mark)
|
||
(match-forward "//" mark))
|
||
(loop (line-start mark 1 'LIMIT) colon-line-end))
|
||
((match-forward "/*" mark)
|
||
(loop (or (search-forward "*/" mark gend) gend) colon-line-end))
|
||
((re-match-forward "case[ \t\n].*:\\|[a-zA-Z0-9_$]*[ \t\n]*:"
|
||
mark gend false)
|
||
(loop (re-match-end 0) (line-end mark 0)))
|
||
((and colon-line-end (mark> colon-line-end mark))
|
||
(- (mark-indentation mark)
|
||
(ref-variable c-label-offset mark)))
|
||
(else
|
||
(mark-column mark)))))))
|
||
|
||
(define (c-indent-expression expression-start)
|
||
(let ((end
|
||
(mark-left-inserting-copy
|
||
(line-start (forward-sexp expression-start 1 'ERROR) 0))))
|
||
(if (mark< expression-start end)
|
||
(let loop
|
||
((start expression-start)
|
||
(state false)
|
||
(indent-stack (list false))
|
||
(contain-stack (list expression-start))
|
||
(last-depth 0))
|
||
(call-with-values
|
||
(lambda () (c-indent-expression:parse-line start end state))
|
||
(lambda (start state)
|
||
(let* ((depth (parse-state-depth state))
|
||
(depth-delta (- depth last-depth))
|
||
(indent-stack (adjust-stack depth-delta indent-stack))
|
||
(contain-stack (adjust-stack depth-delta contain-stack))
|
||
(indent-line
|
||
(lambda ()
|
||
(if (not (line-blank? start))
|
||
(c-indent-expression:per-line
|
||
(skip-chars-forward " \t" start)
|
||
expression-start
|
||
indent-stack
|
||
contain-stack)))))
|
||
(if (not (car contain-stack))
|
||
(set-car! contain-stack
|
||
(or (parse-state-containing-sexp state)
|
||
(backward-sexp start 1 'LIMIT))))
|
||
(if (mark= start end)
|
||
(begin
|
||
(mark-temporary! end)
|
||
(indent-line))
|
||
(begin
|
||
(indent-line)
|
||
(loop start state indent-stack contain-stack
|
||
depth))))))))))
|
||
|
||
(define (c-indent-expression:parse-line start end state)
|
||
(let loop ((start start) (state state))
|
||
(if (and state (parse-state-in-comment? state))
|
||
(c-indent-line start))
|
||
(let ((start* (line-start start 1)))
|
||
(let ((state* (parse-partial-sexp start start* false false state)))
|
||
(cond ((mark= start* end)
|
||
(values start* state*))
|
||
((parse-state-in-comment? state*)
|
||
(if (not (and state (parse-state-in-comment? state)))
|
||
(c-comment-indent (parse-state-comment-start state*)))
|
||
(loop start* state*))
|
||
((parse-state-in-string? state*)
|
||
(loop start* state*))
|
||
(else
|
||
(values start* state*)))))))
|
||
|
||
(define (c-indent-expression:per-line start expression-start
|
||
indent-stack contain-stack)
|
||
(let ((indentation
|
||
(indent-line:adjust-indentation
|
||
start
|
||
(cond ((not (car indent-stack))
|
||
(let ((indentation
|
||
(let ((indentation (calculate-indentation start #f)))
|
||
(if (exact-integer? indentation)
|
||
indentation
|
||
(nonstandard-indentation start indentation)))))
|
||
(set-car! indent-stack indentation)
|
||
indentation))
|
||
((not (char-match-forward #\{ (car contain-stack)))
|
||
(car indent-stack))
|
||
(else
|
||
;; Line is at statement level. Is it a new
|
||
;; statement? Is it an else? Find last non-comment
|
||
;; character before this line.
|
||
(let ((mark (backward-to-noncomment start expression-start)))
|
||
(cond ((not (memv (extract-left-char mark)
|
||
'(#F #\, #\; #\} #\: #\{)))
|
||
(+ (ref-variable c-continued-statement-offset mark)
|
||
(mark-column
|
||
(backward-to-start-of-continued-exp
|
||
mark
|
||
(car contain-stack)))
|
||
(if (char-match-forward #\{ start)
|
||
(ref-variable c-continued-brace-offset mark)
|
||
0)))
|
||
((looking-at-keyword? "else" start)
|
||
(mark-indentation
|
||
(backward-to-start-of-if mark expression-start)))
|
||
(else
|
||
(car indent-stack)))))))))
|
||
(if (not (char-match-forward #\# start))
|
||
(maybe-change-indentation indentation start))))
|
||
|
||
(define (whitespace-start start end)
|
||
(skip-chars-backward " \t\n" start end))
|
||
|
||
(define (whitespace-end start end)
|
||
(skip-chars-forward " \t\n" start end))
|
||
|
||
(define (looking-at-keyword? keyword start)
|
||
(let ((end (line-end start 0)))
|
||
(and (re-match-forward (string-append keyword "\\b") start end false)
|
||
(not (re-match-forward (string-append keyword "\\s_") start end
|
||
false)))))
|
||
|
||
(define (backward-to-noncomment start end)
|
||
(let loop ((start start))
|
||
(let ((mark
|
||
(let ((mark (whitespace-start start end)))
|
||
(or (match-backward "*/" mark)
|
||
mark))))
|
||
(let ((state (parse-partial-sexp end mark)))
|
||
(if (parse-state-in-comment? state)
|
||
(loop (parse-state-comment-start state))
|
||
(let ((mark* (indentation-end mark)))
|
||
(cond ((not (char-match-forward #\# mark*)) mark)
|
||
((mark<= mark* end) mark*)
|
||
(else (loop mark*)))))))))
|
||
|
||
(define (backward-to-start-of-continued-exp start end)
|
||
(let ((mark
|
||
(line-start (if (char-match-backward #\) start)
|
||
(backward-sexp start 1 'LIMIT)
|
||
start)
|
||
0)))
|
||
(horizontal-space-end (if (mark<= mark end) (mark1+ end) mark))))
|
||
|
||
(define (backward-to-start-of-if start end)
|
||
(let loop ((mark start) (if-level 1))
|
||
(let ((mark (backward-sexp mark 1 'LIMIT)))
|
||
(let ((adjust-level
|
||
(lambda (if-level)
|
||
(if (= if-level 0)
|
||
mark
|
||
(loop mark if-level)))))
|
||
(cond ((looking-at-keyword? "else" mark)
|
||
(adjust-level (+ if-level 1)))
|
||
((looking-at-keyword? "if" mark)
|
||
(adjust-level (- if-level 1)))
|
||
((mark>= mark end)
|
||
(adjust-level if-level))
|
||
(else
|
||
end))))))
|
||
|
||
(define (adjust-stack depth-delta stack)
|
||
(cond ((= depth-delta 0)
|
||
stack)
|
||
((> depth-delta 0)
|
||
(let loop ((depth-delta depth-delta) (stack stack))
|
||
(if (= 1 depth-delta)
|
||
(cons false stack)
|
||
(loop (- depth-delta 1) (cons false stack)))))
|
||
(else
|
||
(let loop ((depth-delta depth-delta) (stack stack))
|
||
(if (= -1 depth-delta)
|
||
(cdr stack)
|
||
(loop (+ depth-delta 1) (cdr stack)))))))
|