improve decompiler handling of syntax object
original commit: 5e49e0adea
This commit is contained in:
Matthew Flatt
parent
1f9a6339e4
commit
32d8828ab5
|
|
@ -47,15 +47,16 @@
|
|||
|
||||
;; Main entry:
|
||||
(define (decompile top)
|
||||
(match top
|
||||
[(struct compilation-top (max-let-depth prefix form))
|
||||
(let-values ([(globs defns) (decompile-prefix prefix)])
|
||||
`(begin
|
||||
,@defns
|
||||
,(decompile-form form globs '(#%globals) (make-hasheq))))]
|
||||
[else (error 'decompile "unrecognized: ~e" top)]))
|
||||
(let ([stx-ht (make-hasheq)])
|
||||
(match top
|
||||
[(struct compilation-top (max-let-depth prefix form))
|
||||
(let-values ([(globs defns) (decompile-prefix prefix stx-ht)])
|
||||
`(begin
|
||||
,@defns
|
||||
,(decompile-form form globs '(#%globals) (make-hasheq) stx-ht)))]
|
||||
[else (error 'decompile "unrecognized: ~e" top)])))
|
||||
|
||||
(define (decompile-prefix a-prefix)
|
||||
(define (decompile-prefix a-prefix stx-ht)
|
||||
(match a-prefix
|
||||
[(struct prefix (num-lifts toplevels stxs))
|
||||
(let ([lift-ids (for/list ([i (in-range num-lifts)])
|
||||
|
|
@ -89,37 +90,99 @@
|
|||
num-lifts)
|
||||
(map (lambda (stx id)
|
||||
`(define ,id ,(if stx
|
||||
`(#%decode-syntax ,(stx-encoded stx))
|
||||
`(#%decode-syntax
|
||||
,(decompile-stx (stx-encoded stx) stx-ht))
|
||||
#f)))
|
||||
stxs stx-ids)))]
|
||||
[else (error 'decompile-prefix "huh?: ~e" a-prefix)]))
|
||||
|
||||
(define (decompile-stx stx stx-ht)
|
||||
(or (hash-ref stx-ht stx #f)
|
||||
(let ([p (mcons #f #f)])
|
||||
(hash-set! stx-ht stx p)
|
||||
(match stx
|
||||
[(wrapped datum wraps tamper-status)
|
||||
(set-mcar! p (case tamper-status
|
||||
[(clean) 'wrap]
|
||||
[(tainted) 'wrap-tainted]
|
||||
[(armed) 'wrap-armed]))
|
||||
(set-mcdr! p (mcons
|
||||
(cond
|
||||
[(pair? datum)
|
||||
(cons (decompile-stx (car datum) stx-ht)
|
||||
(let loop ([l (cdr datum)])
|
||||
(cond
|
||||
[(null? l) null]
|
||||
[(pair? l)
|
||||
(cons (decompile-stx (car l) stx-ht)
|
||||
(loop (cdr l)))]
|
||||
[else
|
||||
(decompile-stx l stx-ht)])))]
|
||||
[(vector? datum)
|
||||
(for/vector ([e (in-vector datum)])
|
||||
(decompile-stx e stx-ht))]
|
||||
[(box? datum)
|
||||
(box (decompile-stx (unbox datum) stx-ht))]
|
||||
[else datum])
|
||||
(let loop ([wraps wraps])
|
||||
(cond
|
||||
[(null? wraps) null]
|
||||
[else
|
||||
(or (hash-ref stx-ht wraps #f)
|
||||
(let ([p (mcons #f #f)])
|
||||
(hash-set! stx-ht wraps p)
|
||||
(set-mcar! p (decompile-wrap (car wraps) stx-ht))
|
||||
(set-mcdr! p (loop (cdr wraps)))
|
||||
p))]))))
|
||||
p]))))
|
||||
|
||||
(define (decompile-wrap w stx-ht)
|
||||
(or (hash-ref stx-ht w #f)
|
||||
(let ([v (match w
|
||||
[(lexical-rename has-free-id-renames?
|
||||
ignored
|
||||
alist)
|
||||
`(,(if has-free-id-renames? 'lexical/free-id=? 'lexical) . ,alist)]
|
||||
[(phase-shift amt src dest)
|
||||
`(phase-shift ,amt ,src ,dest)]
|
||||
[(wrap-mark val)
|
||||
val]
|
||||
[(prune sym)
|
||||
`(prune ,sym)]
|
||||
[(module-rename phase kind set-id unmarshals renames mark-renames plus-kern?)
|
||||
`(module-rename ,phase ,kind ,set-id ,unmarshals ,renames ,mark-renames ,plus-kern?)]
|
||||
[(top-level-rename flag)
|
||||
`(top-level-rename ,flag)]
|
||||
[else w])])
|
||||
(hash-set! stx-ht w v)
|
||||
v)))
|
||||
|
||||
(define (mpi->string modidx)
|
||||
(cond
|
||||
[(symbol? modidx) modidx]
|
||||
[else (collapse-module-path-index modidx (current-directory))]))
|
||||
|
||||
(define (decompile-module mod-form stack)
|
||||
(define (decompile-module mod-form stack stx-ht)
|
||||
(match mod-form
|
||||
[(struct mod (name srcname self-modidx prefix provides requires body syntax-body unexported
|
||||
max-let-depth dummy lang-info internal-context))
|
||||
(let-values ([(globs defns) (decompile-prefix prefix)]
|
||||
(let-values ([(globs defns) (decompile-prefix prefix stx-ht)]
|
||||
[(stack) (append '(#%modvars) stack)]
|
||||
[(closed) (make-hasheq)])
|
||||
`(module ,name ....
|
||||
,@defns
|
||||
,@(map (lambda (form)
|
||||
(decompile-form form globs stack closed))
|
||||
(decompile-form form globs stack closed stx-ht))
|
||||
syntax-body)
|
||||
,@(map (lambda (form)
|
||||
(decompile-form form globs stack closed))
|
||||
(decompile-form form globs stack closed stx-ht))
|
||||
body)))]
|
||||
[else (error 'decompile-module "huh?: ~e" mod-form)]))
|
||||
|
||||
(define (decompile-form form globs stack closed)
|
||||
(define (decompile-form form globs stack closed stx-ht)
|
||||
(match form
|
||||
[(? mod?)
|
||||
(decompile-module form stack)]
|
||||
(decompile-module form stack stx-ht)]
|
||||
[(struct def-values (ids rhs))
|
||||
`(define-values ,(map (lambda (tl)
|
||||
(match tl
|
||||
|
|
@ -129,23 +192,23 @@
|
|||
,(decompile-expr rhs globs stack closed))]
|
||||
[(struct def-syntaxes (ids rhs prefix max-let-depth))
|
||||
`(define-syntaxes ,ids
|
||||
,(let-values ([(globs defns) (decompile-prefix prefix)])
|
||||
,(let-values ([(globs defns) (decompile-prefix prefix stx-ht)])
|
||||
`(let ()
|
||||
,@defns
|
||||
,(decompile-form rhs globs '(#%globals) closed))))]
|
||||
,(decompile-form rhs globs '(#%globals) closed stx-ht))))]
|
||||
[(struct def-for-syntax (ids rhs prefix max-let-depth))
|
||||
`(define-values-for-syntax ,ids
|
||||
,(let-values ([(globs defns) (decompile-prefix prefix)])
|
||||
,(let-values ([(globs defns) (decompile-prefix prefix stx-ht)])
|
||||
`(let ()
|
||||
,@defns
|
||||
,(decompile-form rhs globs '(#%globals) closed))))]
|
||||
,(decompile-form rhs globs '(#%globals) closed stx-ht))))]
|
||||
[(struct seq (forms))
|
||||
`(begin ,@(map (lambda (form)
|
||||
(decompile-form form globs stack closed))
|
||||
(decompile-form form globs stack closed stx-ht))
|
||||
forms))]
|
||||
[(struct splice (forms))
|
||||
`(begin ,@(map (lambda (form)
|
||||
(decompile-form form globs stack closed))
|
||||
(decompile-form form globs stack closed stx-ht))
|
||||
forms))]
|
||||
[(struct req (reqs dummy))
|
||||
`(#%require . (#%decode-syntax ,reqs))]
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user