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

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

@ -1,12 +1,13 @@
(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))
;; Problem: If stx1 and stx2 are two distinguishable syntax objects, it ;; Problem: If stx1 and stx2 are two distinguishable syntax objects, it
;; still may be the case that (syntax-e stx1) and (syntax-e stx2) are ;; still may be the case that (syntax-e stx1) and (syntax-e stx2) are
;; indistinguishable. ;; indistinguishable.
;; Solution: Rather than map stx to (syntax-e stx), in the cases where ;; Solution: Rather than map stx to (syntax-e stx), in the cases where
;; (syntax-e stx) is confusable, map it to a different, unique, value. ;; (syntax-e stx) is confusable, map it to a different, unique, value.
;; - stx is identifier : map it to an uninterned symbol w/ same rep ;; - stx is identifier : map it to an uninterned symbol w/ same rep
@ -16,15 +17,15 @@
;; NOTE: Nulls are only wrapped when *not* list-terminators. ;; NOTE: Nulls are only wrapped when *not* list-terminators.
;; If they were always wrapped, the pretty-printer would screw up ;; If they were always wrapped, the pretty-printer would screw up
;; list printing (I think). ;; list printing (I think).
(define-struct syntax-dummy (val)) (define-struct syntax-dummy (val))
;; A SuffixOption is one of ;; A SuffixOption is one of
;; - 'never -- never ;; - 'never -- never
;; - 'always -- suffix > 0 ;; - 'always -- suffix > 0
;; - 'over-limit -- suffix > limit ;; - 'over-limit -- suffix > limit
;; - 'all-if-over-limit -- suffix > 0 if any over limit ;; - 'all-if-over-limit -- suffix > 0 if any over limit
;; syntax->datum/tables : stx [partition% num SuffixOption] ;; syntax->datum/tables : stx [partition% num SuffixOption]
;; -> (values s-expr hashtable hashtable) ;; -> (values s-expr hashtable hashtable)
;; When partition is not false, tracks the partititions that subterms belong to ;; When partition is not false, tracks the partititions that subterms belong to
@ -39,7 +40,7 @@
(case-lambda (case-lambda
[(stx) (table stx #f #f 'never)] [(stx) (table stx #f #f 'never)]
[(stx partition limit suffixopt) (table stx partition limit suffixopt)])) [(stx partition limit suffixopt) (table stx partition limit suffixopt)]))
;; table : syntax maybe-partition% maybe-num SuffixOption -> (values s-expr hashtable hashtable) ;; table : syntax maybe-partition% maybe-num SuffixOption -> (values s-expr hashtable hashtable)
(define (table stx partition limit suffixopt) (define (table stx partition limit suffixopt)
(define (make-identifier-proxy id) (define (make-identifier-proxy id)
@ -53,7 +54,7 @@
(if (<= n limit) (if (<= n limit)
(unintern (syntax-e id)) (unintern (syntax-e id))
(suffix (syntax-e id) n)))))) (suffix (syntax-e id) n))))))
(let/ec escape (let/ec escape
(let ([flat=>stx (make-hash-table)] (let ([flat=>stx (make-hash-table)]
[stx=>flat (make-hash-table)]) [stx=>flat (make-hash-table)])
@ -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,9 +117,30 @@
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)))
(define (suffix sym n) (define (suffix sym n)
(string->uninterned-symbol (format "~a:~a" sym n))) (string->uninterned-symbol (format "~a:~a" sym n)))