#| -*-Scheme-*-

$Id: cinden.scm,v 1.23 2003/02/14 18:28:11 cph Exp $

Copyright 1986, 1989-1999 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., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
USA.

|#

;;;; C Indentation (from GNU Emacs)

(declare (usual-integrations))

(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)))))))