* Added a comment-handler parameter that binds a procedure to be invoked
everytime a multiline comment is found.
This commit is contained in:
parent
c8894f1e68
commit
2fdaf456f8
BIN
lib/ikarus.boot
BIN
lib/ikarus.boot
Binary file not shown.
|
@ -225,27 +225,40 @@
|
||||||
(lambda ()
|
(lambda ()
|
||||||
(error 'tokenize
|
(error 'tokenize
|
||||||
"end of file encountered while inside a #|-style comment")))
|
"end of file encountered while inside a #|-style comment")))
|
||||||
|
(define apprev
|
||||||
|
(lambda (str i ac)
|
||||||
|
(cond
|
||||||
|
[(fx= i (string-length str)) ac]
|
||||||
|
[else
|
||||||
|
(apprev str (fx+ i 1) (cons (string-ref str i) ac))])))
|
||||||
(define multiline-comment
|
(define multiline-comment
|
||||||
(lambda (p)
|
(lambda (p)
|
||||||
(let ([c (read-char p)])
|
(define f
|
||||||
(cond
|
(lambda (p ac)
|
||||||
[(eof-object? c) (multiline-error)]
|
(let ([c (read-char p)])
|
||||||
[($char= #\| c)
|
(cond
|
||||||
(let ([c (read-char p)])
|
[(eof-object? c) (multiline-error)]
|
||||||
(cond
|
[($char= #\| c)
|
||||||
[(eof-object? c) (multiline-error)]
|
(let ([c (read-char p)])
|
||||||
[($char= #\# c) (void)]
|
(cond
|
||||||
[else (multiline-comment p)]))]
|
[(eof-object? c) (multiline-error)]
|
||||||
[($char= #\# c)
|
[($char= #\# c) ac]
|
||||||
(let ([c (read-char p)])
|
[else (f p (cons c ac))]))]
|
||||||
(cond
|
[($char= #\# c)
|
||||||
[(eof-object? c) (multiline-error)]
|
(let ([c (read-char p)])
|
||||||
[($char= #\| c)
|
(cond
|
||||||
(multiline-comment p)
|
[(eof-object? c) (multiline-error)]
|
||||||
(multiline-comment p)]
|
[($char= #\| c)
|
||||||
[else
|
(let ([v (multiline-comment p)])
|
||||||
(multiline-comment p)]))]
|
(if (string? v)
|
||||||
[else (multiline-comment p)]))))
|
(f p (apprev v 0 ac))
|
||||||
|
(f p ac)))]
|
||||||
|
[else
|
||||||
|
(f p (cons c (cons #\# ac)))]))]
|
||||||
|
[else (f p (cons c ac))]))))
|
||||||
|
(let ([ac (f p '())])
|
||||||
|
((comment-handler)
|
||||||
|
(list->string (reverse ac))))))
|
||||||
(define read-binary
|
(define read-binary
|
||||||
(lambda (ac chars p)
|
(lambda (ac chars p)
|
||||||
(let ([c (read-char p)])
|
(let ([c (read-char p)])
|
||||||
|
@ -650,6 +663,13 @@
|
||||||
(if (input-port? p)
|
(if (input-port? p)
|
||||||
(read p)
|
(read p)
|
||||||
(error 'read "~s is not an input port" p))]))
|
(error 'read "~s is not an input port" p))]))
|
||||||
|
(primitive-set! 'comment-handler
|
||||||
|
(make-parameter
|
||||||
|
(lambda (x) (void))
|
||||||
|
(lambda (x)
|
||||||
|
(unless (procedure? x)
|
||||||
|
(error 'comment-handler "~s is not a procedure" x))
|
||||||
|
x)))
|
||||||
(let ()
|
(let ()
|
||||||
(define read-and-eval
|
(define read-and-eval
|
||||||
(lambda (p)
|
(lambda (p)
|
||||||
|
|
|
@ -67,7 +67,7 @@
|
||||||
call-with-values values
|
call-with-values values
|
||||||
make-parameter dynamic-wind
|
make-parameter dynamic-wind
|
||||||
display write print-graph fasl-write printf format print-error
|
display write print-graph fasl-write printf format print-error
|
||||||
read-token read
|
read-token read comment-handler
|
||||||
error exit call/cc
|
error exit call/cc
|
||||||
error-handler
|
error-handler
|
||||||
eval current-eval interpret compile compile-file new-cafe load
|
eval current-eval interpret compile compile-file new-cafe load
|
||||||
|
|
Loading…
Reference in New Issue