suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

cache readtable makers

Browse Source 
svn: r6907
This commit is contained in:
Eli Barzilay 2007-07-13 18:00:40 +00:00
parent d7e79cde81
commit fca1c6112c
1 changed files with 36 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

39
collects/scribble/reader.ss
View File

@ -98,6 +98,19 @@
(let ([m (*regexp-match-peek-positions pattern input-port)]) (let ([m (*regexp-match-peek-positions pattern input-port)])
(and m (read-bytes (cdar m) input-port)))) (and m (read-bytes (cdar m) input-port))))
;; Utility for readtable-based caches
(define (readtable-cached fun)
(let ([cache (make-hash-table 'weak)])
(letrec ([readtable-cached
(case-lambda
[(rt) (hash-table-get cache rt
(lambda ()
(let ([r (fun rt)])
(hash-table-put! cache rt r)
r)))]
[() (readtable-cached (current-readtable))])])
readtable-cached)))
;; Skips whitespace characters, sensitive to the current readtable's ;; Skips whitespace characters, sensitive to the current readtable's
;; definition of whitespace; optimizes common spaces when possible ;; definition of whitespace; optimizes common spaces when possible
(define skip-whitespace (define skip-whitespace
@ -117,13 +130,10 @@
(and (char? like-ch/sym) (char-whitespace? like-ch/sym))) (and (char? like-ch/sym) (char-whitespace? like-ch/sym)))
;; `char-whitespace?' is fine for the default readtable ;; `char-whitespace?' is fine for the default readtable
(char-whitespace? ch))) (char-whitespace? ch)))
(define (plain-readtable? rt) (define plain-readtable?
(hash-table-get plain-readtables rt (readtable-cached
(lambda () (lambda (rt)
(let ([plain? (andmap (lambda (ch) (whitespace? ch rt)) (andmap (lambda (ch) (whitespace? ch rt)) plain-spaces-list))))
plain-spaces-list)])
(hash-table-put! plain-readtables rt #t)
rt))))
(lambda (port) (lambda (port)
(let* ([rt (current-readtable)] [plain? (plain-readtable? rt)]) (let* ([rt (current-readtable)] [plain? (plain-readtable? rt)])
(let loop () (let loop ()
@ -473,9 +483,10 @@
;; -------------------------------------------------------------------------- ;; --------------------------------------------------------------------------
;; readtables ;; readtables
(define (make-at-readtable) (define make-at-readtable
(make-readtable (current-readtable) (readtable-cached
ch:command 'non-terminating-macro dispatcher)) (lambda (rt)
(make-readtable rt ch:command 'non-terminating-macro dispatcher))))
(provide use-at-readtable) (provide use-at-readtable)
(define (use-at-readtable) (define (use-at-readtable)
@ -486,8 +497,10 @@
;; terminating macro characters (otherwise it behaves the same; the only ;; terminating macro characters (otherwise it behaves the same; the only
;; difference is that `a|b|c' is three symbols and `@foo@bar' are two ;; difference is that `a|b|c' is three symbols and `@foo@bar' are two
;; @-forms) ;; @-forms)
(define (make-command-readtable) (define make-command-readtable
(make-readtable (current-readtable) (readtable-cached
(lambda (rt)
(make-readtable rt
ch:command 'terminating-macro dispatcher ch:command 'terminating-macro dispatcher
#\| 'terminating-macro #\| 'terminating-macro
(lambda (char inp source-name line-num col-num position) (lambda (char inp source-name line-num col-num position)
@ -498,7 +511,7 @@
(datum->syntax-object (datum->syntax-object
#f (string->symbol (bytes->string/utf-8 (cadr m))) #f (string->symbol (bytes->string/utf-8 (cadr m)))
(list source-name line-num col-num position (list source-name line-num col-num position
(add1 (bytes-length (car m))))))))) (add1 (bytes-length (car m)))))))))))
(define default-src (gensym 'scribble-reader)) (define default-src (gensym 'scribble-reader))
(define (src-name src port) (define (src-name src port)