finish decompiler on syntax objects
svn: r12077
This commit is contained in:
Matthew Flatt
parent
122f8d41dc
commit
e2d4bc0d2b
|
|
@ -75,7 +75,9 @@
|
|||
(if (null? stx-ids) null '(#%stx-array))
|
||||
lift-ids)
|
||||
(map (lambda (stx id)
|
||||
`(define ,id (#%decode-syntax ,(stx-encoded stx))))
|
||||
`(define ,id ,(if stx
|
||||
`(#%decode-syntax ,(stx-encoded stx))
|
||||
#f)))
|
||||
stxs stx-ids)))]
|
||||
[else (error 'decompile-prefix "huh?: ~e" a-prefix)]))
|
||||
|
||||
|
|
@ -304,7 +306,8 @@
|
|||
+ - * / min max bitwise-and bitwise-ior
|
||||
arithmetic-shift vector-ref string-ref bytes-ref
|
||||
set-mcar! set-mcdr! cons mcons))]
|
||||
[(4) (memq (car a) '(vector-set! string-set! bytes-set!))]))
|
||||
[(4) (memq (car a) '(vector-set! string-set! bytes-set!))]
|
||||
[else #f]))
|
||||
(cons '#%in a)
|
||||
a))
|
||||
|
||||
|
|
|
|||
|
|
@ -306,7 +306,7 @@
|
|||
;; not sure if it's really unsigned
|
||||
(integer-bytes->integer (read-bytes 4 p) #f #f))
|
||||
|
||||
(define-struct cport ([pos #:mutable] orig-port size bytes symtab shared-offsets decoded rns))
|
||||
(define-struct cport ([pos #:mutable] orig-port size bytes symtab shared-offsets decoded rns mpis))
|
||||
|
||||
(define (cp-getc cp)
|
||||
(begin-with-definitions
|
||||
|
|
@ -430,6 +430,11 @@
|
|||
;; Synatx unmarshaling
|
||||
|
||||
(define-form-struct wrapped (datum wraps certs))
|
||||
(define-form-struct lexical-rename (alist))
|
||||
(define-form-struct phase-shift (amt src dest))
|
||||
(define-form-struct module-rename (phase kind set-id unmarshals renames mark-renames plus-kern?))
|
||||
(define-form-struct all-from-module (path phase src-phase exceptions prefix))
|
||||
(define-form-struct module-binding (path mod-phase import-phase id nominal-path nominal-phase nominal-id))
|
||||
|
||||
(define (decode-stx cp v)
|
||||
(if (integer? v)
|
||||
|
|
@ -515,15 +520,107 @@
|
|||
;; a mark
|
||||
(string->symbol (format "mark~a" (car a)))]
|
||||
[(vector? a)
|
||||
`(#%decode-lexical-rename ,a)]
|
||||
(make-lexical-rename
|
||||
(let ([top (+ (/ (- (vector-length a) 2) 2) 2)])
|
||||
(let loop ([i 2])
|
||||
(if (= i top)
|
||||
null
|
||||
(cons (cons (vector-ref a i)
|
||||
(vector-ref a (+ (- top 2) i)))
|
||||
(loop (+ i 1)))))))]
|
||||
[(pair? a)
|
||||
`(#%decode-module-rename ,a)]
|
||||
(let-values ([(plus-kern? a) (if (eq? (car a) #t)
|
||||
(values #t (cdr a))
|
||||
(values #f a))])
|
||||
(match a
|
||||
[`(,phase ,kind ,set-id ,maybe-unmarshals . ,renames)
|
||||
(let-values ([(unmarshals renames mark-renames)
|
||||
(if (vector? maybe-unmarshals)
|
||||
(values null maybe-unmarshals renames)
|
||||
(values maybe-unmarshals
|
||||
(car renames)
|
||||
(cdr renames)))])
|
||||
(make-module-rename phase
|
||||
(if kind 'marked 'normal)
|
||||
set-id
|
||||
(map (lambda (u)
|
||||
(let ([just-phase? (number? (cddr u))])
|
||||
(let-values ([(exns prefix)
|
||||
(if just-phase?
|
||||
(values null #f)
|
||||
(let loop ([u (if just-phase? null (cdddr u))]
|
||||
[a null])
|
||||
(if (pair? u)
|
||||
(loop (cdr u) (cons (car u) a))
|
||||
(values (reverse a) u))))])
|
||||
(make-all-from-module
|
||||
(parse-module-path-index cp (car u))
|
||||
(cadr u)
|
||||
(if just-phase?
|
||||
(cddr u)
|
||||
(caddr u))
|
||||
exns
|
||||
prefix))))
|
||||
unmarshals)
|
||||
(let loop ([i 0])
|
||||
(if (= i (vector-length renames))
|
||||
null
|
||||
(cons
|
||||
(let ([key (vector-ref renames i)]
|
||||
[make-mapping
|
||||
(lambda (path mod-phase import-phase id nominal-path nominal-phase nominal-id)
|
||||
(make-module-binding
|
||||
(parse-module-path-index cp path)
|
||||
mod-phase
|
||||
import-phase
|
||||
id
|
||||
(parse-module-path-index cp nominal-path)
|
||||
nominal-phase
|
||||
(if (eq? id nominal-id) #t nominal-id)))])
|
||||
(cons key
|
||||
(let ([m (vector-ref renames (add1 i))]
|
||||
[parse-nominal-modidx-plus-phase
|
||||
(lambda (modidx mod-phase exportname nominal-modidx-plus-phase nom-exportname)
|
||||
(match nominal-modidx-plus-phase
|
||||
[`(,nominal-modidx ,import-phase-plus-nominal-phase)
|
||||
(match import-phase-plus-nominal-phase
|
||||
[`(,import-phase ,nom-phase)
|
||||
(make-mapping modidx mod-phase import-phase exportname
|
||||
nominal-modidx nom-phase nom-exportname)]
|
||||
[import-phase
|
||||
(make-mapping modidx mod-phase import-phase exportname
|
||||
modidx mod-phase nom-exportname)])]
|
||||
[nominal-modidx
|
||||
(make-mapping modidx mod-phase '* exportname
|
||||
nominal-modidx mod-phase nom-exportname)]))])
|
||||
(match m
|
||||
[`(,modidx ,mod-phase ,exportname ,nominal-modidx-plus-phase . ,nominal-exportname)
|
||||
(parse-nominal-modidx-plus-phase modidx mod-phase exportname
|
||||
nominal-modidx-plus-phase nominal-exportname)]
|
||||
[`(,modidx ,exportname ,nominal-modidx-plus-phase . ,nominal-exportname)
|
||||
(parse-nominal-modidx-plus-phase modidx '* exportname
|
||||
nominal-modidx-plus-phase nominal-exportname)]
|
||||
[`(,modidx ,nominal-modidx)
|
||||
(make-mapping modidx '* '* key nominal-modidx '* key)]
|
||||
[`(,modidx ,exportname)
|
||||
(make-mapping modidx '* '* exportname modidx '* exportname)]
|
||||
[modidx
|
||||
(make-mapping modidx '* '* key modidx '* key)]))))
|
||||
(loop (+ i 2)))))
|
||||
mark-renames
|
||||
(and plus-kern? 'plus-kern)))]
|
||||
[else (error "bad module rename: ~e" a)]))]
|
||||
[(boolean? a)
|
||||
`(#%top-level-rename ,a)]
|
||||
[(symbol? a)
|
||||
'(#%mark-barrier)]
|
||||
[(box? a)
|
||||
`(#%phase-shift ,(unbox a))]
|
||||
(match (unbox a)
|
||||
[`#(,amt ,src ,dest #f)
|
||||
(make-phase-shift amt
|
||||
(parse-module-path-index cp src)
|
||||
(parse-module-path-index cp dest))]
|
||||
[else (error 'parse "bad phase shift: ~e" a)])]
|
||||
[else (error 'decode-wraps "bad wrap element: ~e" a)])))
|
||||
w)))
|
||||
|
||||
|
|
@ -544,6 +641,20 @@
|
|||
(vector-set! (cport-symtab cp) pos v)
|
||||
(vector-set! (cport-decoded cp) pos #t))
|
||||
|
||||
(define (parse-module-path-index cp s)
|
||||
(cond
|
||||
[(not s) #f]
|
||||
[(module-path-index? s)
|
||||
(hash-ref (cport-mpis cp) s
|
||||
(lambda ()
|
||||
(let-values ([(name base) (module-path-index-split s)])
|
||||
(let ([v `(module-path-index-join
|
||||
(quote ,name)
|
||||
,(parse-module-path-index cp base))])
|
||||
(hash-set! (cport-mpis cp) s v)
|
||||
v))))]
|
||||
[else `(quote ,s)]))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Main parsing loop
|
||||
|
||||
|
|
@ -784,7 +895,7 @@
|
|||
|
||||
(define symtab (make-vector symtabsize (make-not-ready)))
|
||||
|
||||
(define cp (make-cport 0 port size* rst symtab so* (make-vector symtabsize #f) (make-hash)))
|
||||
(define cp (make-cport 0 port size* rst symtab so* (make-vector symtabsize #f) (make-hash) (make-hash)))
|
||||
(for/list ([i (in-range 1 symtabsize)])
|
||||
(when (not-ready? (vector-ref symtab i))
|
||||
(set-cport-pos! cp (vector-ref so* (sub1 i)))
|
||||
|
|
|
|||
|
|
@ -1088,11 +1088,13 @@
|
|||
|
||||
(define max-call-head-width 5)
|
||||
|
||||
(define (no-sharing? expr count acdr)
|
||||
(if (and found (hash-table-get found (acdr expr) #f))
|
||||
(define (no-sharing? expr count apair? acdr)
|
||||
(if (and found
|
||||
(apair? expr)
|
||||
(hash-table-get found (acdr expr) #f))
|
||||
#f
|
||||
(or (zero? count)
|
||||
(no-sharing? (acdr expr) (sub1 count) acdr))))
|
||||
(no-sharing? (acdr expr) (sub1 count) apair? acdr))))
|
||||
|
||||
(define (style head expr apair? acar acdr)
|
||||
(case (look-in-style-table head)
|
||||
|
|
@ -1100,22 +1102,22 @@
|
|||
syntax-rules
|
||||
shared
|
||||
unless when)
|
||||
(and (no-sharing? expr 1 acdr)
|
||||
(and (no-sharing? expr 1 apair? acdr)
|
||||
pp-lambda))
|
||||
((if set! set!-values)
|
||||
(and (no-sharing? expr 1 acdr)
|
||||
(and (no-sharing? expr 1 apair? acdr)
|
||||
pp-if))
|
||||
((cond case-lambda)
|
||||
(and (no-sharing? expr 0 acdr)
|
||||
(and (no-sharing? expr 0 apair? acdr)
|
||||
pp-cond))
|
||||
((case class)
|
||||
(and (no-sharing? expr 1 acdr)
|
||||
(and (no-sharing? expr 1 apair? acdr)
|
||||
pp-case))
|
||||
((and or import export
|
||||
require require-for-syntax require-for-template
|
||||
provide link
|
||||
public private override rename inherit field init)
|
||||
(and (no-sharing? expr 0 acdr)
|
||||
(and (no-sharing? expr 0 apair? acdr)
|
||||
pp-and))
|
||||
((let letrec let*
|
||||
let-values letrec-values let*-values
|
||||
|
|
@ -1126,20 +1128,21 @@
|
|||
(symbol? (acar (acdr expr))))
|
||||
2
|
||||
1)
|
||||
apair?
|
||||
acdr)
|
||||
pp-let))
|
||||
((begin begin0)
|
||||
(and (no-sharing? expr 0 acdr)
|
||||
(and (no-sharing? expr 0 apair? acdr)
|
||||
pp-begin))
|
||||
((do letrec-syntaxes+values)
|
||||
(and (no-sharing? expr 2 acdr)
|
||||
(and (no-sharing? expr 2 apair? acdr)
|
||||
pp-do))
|
||||
|
||||
((send syntax-case instantiate module)
|
||||
(and (no-sharing? expr 2 acdr)
|
||||
(and (no-sharing? expr 2 apair? acdr)
|
||||
pp-syntax-case))
|
||||
((make-object)
|
||||
(and (no-sharing? expr 1 acdr)
|
||||
(and (no-sharing? expr 1 apair? acdr)
|
||||
pp-make-object))
|
||||
|
||||
(else #f)))
|
||||
|
|
|
|||
|
|
@ -3518,6 +3518,9 @@ static void sfs_note_app(SFS_Info *info, Scheme_Object *rator)
|
|||
{
|
||||
if (!info->pass) {
|
||||
if (!info->tail_pos) {
|
||||
if (SAME_OBJ(scheme_values_func, rator))
|
||||
/* no need to clear for app of `values' */
|
||||
return;
|
||||
if (SCHEME_PRIMP(rator)) {
|
||||
int opt;
|
||||
opt = ((Scheme_Prim_Proc_Header *)rator)->flags & SCHEME_PRIM_OPT_MASK;
|
||||
|
|
|
|||
|
|
@ -5518,7 +5518,7 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w,
|
|||
scheme_unmarshal_wrap_set(ut, local_key, a);
|
||||
} else if (SCHEME_PAIRP(a)) {
|
||||
/* A rename table:
|
||||
- ([#t] <index-num> <phase-num> <bool> [unmarshal] #(<table-elem> ...)
|
||||
- ([#t] <phase-num> <kind-num> <set-identity> [unmarshal] #(<table-elem> ...)
|
||||
. ((<sym> (<marked-list-or-mark> . <target-gensym>) ...) ...)) ; <- marked_names
|
||||
where a <table-elem> is actually two values, one of:
|
||||
- <exname> <modname>
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user