(define h-scm-inside-comment-or-string? #f)

(mistie-def-ctl-seq 'q
  (lambda ()
    (h-ignore-spaces)
    (let* ((old-escape-char mistie-escape-char)
           (c-delim (read-char))
           (ws (h-read-whitespace))
           (nnl (h-number-of-newlines ws))
           (pre? (> nnl 0)))
      (set! mistie-escape-char #f)
      (mistie-push-frame)
      (display (if pre? "<pre" "<code"))
      (display " class=scheme>")
      (display ws)
      (set! h-scm-inside-comment-or-string? #f)
      (mistie-def-char-type h-scm-token-char? h-scm-do-token)
      (mistie-def-char #\newline newline)
      (mistie-def-char #\; h-scm-do-semicolon)
      (mistie-def-char #\" h-scm-do-string)
      (mistie-def-char #\# h-scm-do-hash)
      (if (char=? c-delim #\{)
          (let ((n 0))
            (set! mistie-escape-char #\|)
            (mistie-def-char #\{
              (lambda ()
                (display #\{)
                (set! n (+ n 1))))
            (mistie-def-char #\}
              (lambda ()
                (if (= n 0)
                    (begin
                      (when h-scm-inside-comment-or-string?
                        (set! h-scm-inside-comment-or-string? #f)
                        (mistie-pop-frame)
                        (display "</span>"))
                      (display (if pre? "</pre>" "</code>"))
                      (mistie-pop-frame)
                      (set! mistie-escape-char old-escape-char))
                    (begin
                      (display #\})
                      (set! n (- n 1)))))))
          (mistie-def-char c-delim
            (lambda ()
              (when h-scm-inside-comment-or-string?
                (set! h-scm-inside-comment-or-string? #f)
                (mistie-pop-frame)
                (display "</span>"))
              (display (if pre? "</pre>" "</code>"))
              (mistie-pop-frame)))))))

(define h-scm-delim-char?
  (lambda (c)
    (or (eof-object? c) (char-whitespace? c)
        (memv c '(#\( #\) #\[ #\] #\{ #\} #\' #\` #\"
                     #\; #\, #\@ #\|)))))

(define h-scm-token-char?
  (lambda (c)
    (not (h-scm-delim-char? c))))

(define h-scm-read-token
  (lambda (c)
    (list->string
      (reverse!
        (let loop ((s (list c)) (esc? (char=? c #\\))) 
          (let ((c (peek-char)))
            (cond ((eof-object? c) s)
                  (esc? (loop (cons (read-char) s) #f))
                  ((char=? c #\\) (loop (cons (read-char) s) #t))
                  ((h-scm-delim-char? c) s)
                  (else (loop (cons (read-char) s) #f)))))))))

(define h-scm-do-token
  (lambda (c)
    (if h-scm-inside-comment-or-string?
        (h-write-char c)
        (h-scm-output-token
          (h-scm-read-token c)))))

(define h-scm-token-class
  (lambda (s)
    (cond ((member s h-scm-keywords) 'keyword)
          ((member s h-scm-constants) 'constant)
          ((string=? s ".") #f)
          ((string=? s "...") #f)
          ((and (char=? (string-ref s 0) #\*)
                (char=? (string-ref s (- (string-length s) 1)) #\*))
           'global)
          ((char=? (string-ref s 0) #\:) 'constant)
          ((string->number s) 'number)
          (else 'variable))))

(define h-scm-output-token
  (lambda (s)
    (let ((token-class (h-scm-token-class s)))
      (when token-class
        (display "<span class=")
        (display token-class)
        (display ">"))
      (h-display-string s)
      (if token-class (display "</span>")))))

(define h-scm-do-semicolon
  (lambda ()
    (if h-scm-inside-comment-or-string?
        (display #\;)
        (begin
          (mistie-push-frame)
          (display "<span class=comment>;")
          (set! h-scm-inside-comment-or-string? #t)
          (mistie-def-char #\newline
            (lambda ()
              (display "</span>")
              (set! h-scm-inside-comment-or-string? #f)
              (newline)
              (mistie-pop-frame)))))))

(define h-scm-extended-comment
  (lambda ()
    (let ((nest-count 0))
      (mistie-push-frame)
      (display "<span class=comment>#|")
      (set! h-scm-inside-comment-or-string? #t)
      (mistie-def-char #\|
        (lambda ()
          (write-char #\|)
          (if (eqv? (peek-char) #\#)
              (if (<= nest-count 0)
                  (begin (read-char)
                    (display "#</span>")
                    (mistie-pop-frame))
                  (set! nest-count (- nest-count 1))))))
      (mistie-def-char #\#
        (lambda ()
          (write-char #\#)
          (if (eqv? (peek-char) #\|)
              (begin (read-char)
                (write-char #\|)
                (set! nest-count (+ nest-count 1)))))))))

(define h-scm-do-string
  (lambda ()
    (if h-scm-inside-comment-or-string?
        (display "&quot;")
        (begin
          (mistie-push-frame)
          (display "<span class=string>&quot;")
          (set! h-scm-inside-comment-or-string? #t)
          (mistie-def-char #\\
            (lambda ()
              (when (eqv? (peek-char) #\")
                (read-char) (display "&quot;"))))
          (mistie-def-char #\"
            (lambda ()
              (display "&quot;</span>")
              (set! h-scm-inside-comment-or-string? #f)
              (mistie-pop-frame)))))))

(define h-scm-do-hash
  (lambda ()
    (if h-scm-inside-comment-or-string?
        (write-char #\#)
        (let ((c (read-char)))
          (cond ((eof-object? c) (display #\#))
                ((char=? c #\|) (h-scm-extended-comment))
                ((char=? c #\\)
                 (display "<span class=char>#")
                 (h-display-string (h-scm-read-token c))
                 (display "</span>"))
                ((and (memv c '(#\t #\f))
                      (h-scm-delim-char? (peek-char)))
                 (display "<span class=boolean>#")
                 (write-char c)
                 (display "</span>"))
                (else
                  (display "<span class=constant>#")
                  (if (char=? c #\() ;vector
                      (display "</span>(")
                      (begin
                        (h-display-string (h-scm-read-token c))
                        (display "</span>")))))))))

(mistie-def-ctl-seq 'scmkeyword
  (lambda ()
    (for-each
      (lambda (x)
        (let ((s (symbol->string x)))
          (unless (member s h-scm-keywords)
            (set! h-scm-keywords (cons s h-scm-keywords)))))
      (read))))

(mistie-def-ctl-seq 'scmconstant
  (lambda ()
    (for-each 
      (lambda (x)
        (let ((s (symbol->string x)))
          (unless (member s h-scm-constants)
            (set! h-scm-constants (cons s h-scm-constants)))))
      (read))))

(define h-scm-constants '())

(define h-scm-keywords
  '(
    "=>"
    "and"
    "begin"
    "begin0"
    "case"
    "cond"
    "define"
    "define-macro"
    "define-syntax"
    "defmacro"
    "defstruct"
    "delay"
    "do"
    "else"
    "flet"
    "fluid-let"
    "if"
    "labels"
    "lambda"
    "let"
    "let-syntax"
    "let*"
    "letrec"
    "letrec-syntax"
    "macrolet"
    "or"
    "quasiquote"
    "quote"
    "set!"
    "syntax-rules"
    "unless"
    "unquote"
    "unquote-splicing"
    "when"
    "with"
    "with-handlers"
    ))