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

Macro stepper: abbreviate quote etc when appropriate

Browse Source 
svn: r5929

original commit: 80af3f491cf8d2fb619e1482d8f8890b1e0df390
This commit is contained in:
Ryan Culpepper 2007-04-13 16:54:59 +00:00
parent ce40ab8672
commit d0781e4e82
1 changed files with 42 additions and 9 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

35
collects/macro-debugger/syntax-browser/pretty-helper.ss
View File

@ -1,5 +1,6 @@
(module pretty-helper mzscheme (module pretty-helper mzscheme
(require (lib "class.ss") (require (lib "class.ss")
(lib "stx.ss" "syntax")
"partition.ss") "partition.ss")
(provide (all-defined)) (provide (all-defined))
@ -69,8 +70,19 @@
(hash-table-put! flat=>stx lp-datum obj) (hash-table-put! flat=>stx lp-datum obj)
(hash-table-put! stx=>flat obj lp-datum) (hash-table-put! stx=>flat obj lp-datum)
lp-datum)] lp-datum)]
[(and (syntax? obj) (check+convert-special-expression obj))
=> (lambda (newobj)
(when partition (send partition get-partition obj))
(let* ([inner (cadr newobj)]
[lp-inner-datum (loop inner)]
[lp-datum (list (car newobj) lp-inner-datum)])
(hash-table-put! flat=>stx lp-inner-datum inner)
(hash-table-put! stx=>flat inner lp-inner-datum)
(hash-table-put! flat=>stx lp-datum obj)
(hash-table-put! stx=>flat obj lp-datum)
lp-datum))]
[(syntax? obj) [(syntax? obj)
(void (send partition get-partition obj)) (when partition (send partition get-partition obj))
(let ([lp-datum (loop (syntax-e obj))]) (let ([lp-datum (loop (syntax-e obj))])
(hash-table-put! flat=>stx lp-datum obj) (hash-table-put! flat=>stx lp-datum obj)
(hash-table-put! stx=>flat obj lp-datum) (hash-table-put! stx=>flat obj lp-datum)
@ -105,6 +117,27 @@
flat=>stx flat=>stx
stx=>flat)))) stx=>flat))))
;; check+convert-special-expression : syntax -> #f/syntaxish
(define (check+convert-special-expression stx)
(define stx-list (stx->list stx))
(and stx-list (= 2 (length stx-list))
(let ([kw (car stx-list)]
[expr (cadr stx-list)])
(and (identifier? kw)
(memq (syntax-e kw)
'(quote quasiquote unquote unquote-splicing
syntax quasisyntax unsyntax unsyntax-splicing))
(bound-identifier=? kw (datum->syntax-object stx (syntax-e kw)))
(andmap (lambda (f) (equal? (f stx) (f kw)))
(list syntax-source
syntax-line
syntax-column
syntax-position
syntax-original?
syntax-source-module))
(cons (syntax-e kw)
(list expr))))))
(define (unintern sym) (define (unintern sym)
(string->uninterned-symbol (symbol->string sym))) (string->uninterned-symbol (symbol->string sym)))