(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? "
") (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 "")) (display (if pre? "" "")) (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 "")) (display (if pre? "" "")) (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 "")) (h-display-string s) (if token-class (display ""))))) (define h-scm-do-semicolon (lambda () (if h-scm-inside-comment-or-string? (display #\;) (begin (mistie-push-frame) (display ";") (set! h-scm-inside-comment-or-string? #t) (mistie-def-char #\newline (lambda () (display "") (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 "#|") (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 "#") (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 """) (begin (mistie-push-frame) (display """) (set! h-scm-inside-comment-or-string? #t) (mistie-def-char #\\ (lambda () (when (eqv? (peek-char) #\") (read-char) (display """)))) (mistie-def-char #\" (lambda () (display """) (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 "#") (h-display-string (h-scm-read-token c)) (display "")) ((and (memv c '(#\t #\f)) (h-scm-delim-char? (peek-char))) (display "#") (write-char c) (display "")) (else (display "#") (if (char=? c #\() ;vector (display "(") (begin (h-display-string (h-scm-read-token c)) (display ""))))))))) (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" ))