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

restore use of atomic rewriters for literals

Browse Source 
svn: r15363
This commit is contained in:
Matthew Flatt 2009-07-02 14:49:59 +00:00
parent 8b851e1c00
commit 482816bf34
1 changed files with 21 additions and 17 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

38
collects/redex/private/core-layout.ss
View File

@ -704,28 +704,32 @@
(memq atom '(number variable variable-except variable-not-otherwise-mentioned)))
(list (non-terminal->token col span (format "~s" atom)))]
[(symbol? atom)
(list (make-string-token col span (symbol->string atom) (literal-style)))]
(list (or (rewrite-atomic col span atom)
(make-string-token col span (symbol->string atom) (literal-style))))]
[(string? atom)
(list (make-string-token col span atom (default-style)))]
[else (error 'atom->tokens "unk ~s" atom)]))
(define (rewrite-atomic col span e)
(cond
[(assoc e (atomic-rewrite-table))
=>
(λ (m)
(when (eq? (cadr m) e)
(error 'apply-rewrites "rewritten version of ~s is still ~s" e e))
(let ([p (cadr m)])
(if (procedure? p)
(make-pict-token col span (p))
(make-string-token col span p (non-terminal-style)))))]
[else #f]))
(define (non-terminal->token col span str)
(let ([e (string->symbol str)])
(cond
[(assoc e (atomic-rewrite-table))
=>
(λ (m)
(when (eq? (cadr m) e)
(error 'apply-rewrites "rewritten version of ~s is still ~s" e e))
(let ([p (cadr m)])
(if (procedure? p)
(make-pict-token col span (p))
(make-string-token col span p (non-terminal-style)))))]
[else
(make-string-token col
span
str
(non-terminal-style))])))
(or (rewrite-atomic col span e)
(make-string-token col
span
str
(non-terminal-style)))))
(define (pick-font lst fallback)
(let ([fl (get-face-list 'all)])