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

fix `compiler/zo-parse' & co.

Browse Source
This commit is contained in:
Matthew Flatt 2011-06-29 21:33:59 -06:00
parent 1af8cd07ad
commit 69ad39d45c
4 changed files with 29 additions and 84 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

21
collects/compiler/zo-marshal.rkt
View File

@ -304,7 +304,7 @@
(for/list ([wrap (in-list wraps)]) (for/list ([wrap (in-list wraps)])
(match wrap (match wrap
[(struct phase-shift (amt src dest)) [(struct phase-shift (amt src dest))
(box (vector amt src dest #f))] (box (vector amt src dest #f #f))]
[(struct module-rename (phase kind set-id unmarshals renames mark-renames plus-kern?)) [(struct module-rename (phase kind set-id unmarshals renames mark-renames plus-kern?))
(define encoded-kind (eq? kind 'marked)) (define encoded-kind (eq? kind 'marked))
(define encoded-unmarshals (map encode-all-from-module unmarshals)) (define encoded-unmarshals (map encode-all-from-module unmarshals))
@ -343,18 +343,9 @@
(define-struct protected-symref (val)) (define-struct protected-symref (val))
(define encode-certs
(match-lambda
[(struct certificate:nest (m1 m2))
(list* (encode-mark-map m1) (encode-mark-map m2))]
[(struct certificate:ref (val m))
(list* #f (make-protected-symref val) (encode-mark-map m))]
[(struct certificate:plain (m))
(encode-mark-map m)]))
(define (encode-wrapped w) (define (encode-wrapped w)
(match w (match w
[(struct wrapped (datum wraps certs)) [(struct wrapped (datum wraps tamper-status))
(let* ([enc-datum (let* ([enc-datum
(match datum (match datum
[(cons a b) [(cons a b)
@ -391,9 +382,10 @@
[_ datum])] [_ datum])]
[p (cons enc-datum [p (cons enc-datum
(encode-wraps wraps))]) (encode-wraps wraps))])
(if certs (case tamper-status
(vector p (encode-certs certs)) [(clean) p]
p))])) [(tainted) (vector p)]
[(armed) (vector p #f)]))]))
(define-struct out (s shared-index shared-unsee encoded-wraps)) (define-struct out (s shared-index shared-unsee encoded-wraps))
(define (out-shared v out k) (define (out-shared v out k)
@ -887,7 +879,6 @@
(let ([phase (car l)] (let ([phase (car l)]
[all (append (cadr l) (caddr l))]) [all (append (cadr l) (caddr l))])
(list phase (list phase
(list->vector/#f #f (map provided-insp all))
(list->vector/#f 0 (map (lambda (p) (= 1 (provided-src-phase p))) (list->vector/#f 0 (map (lambda (p) (= 1 (provided-src-phase p)))
all)) all))
(list->vector/#f #f (map (lambda (p) (list->vector/#f #f (map (lambda (p)

53
collects/compiler/zo-parse.rkt
View File

@ -232,8 +232,8 @@
,indirect-provides ,num-indirect-provides ,indirect-provides ,num-indirect-provides
,protects ,et-protects ,protects ,et-protects
,provide-phase-count . ,rest) ,provide-phase-count . ,rest)
(let ([phase-data (take rest (* 9 provide-phase-count))]) (let ([phase-data (take rest (* 8 provide-phase-count))])
(match (list-tail rest (* 9 provide-phase-count)) (match (list-tail rest (* 8 provide-phase-count))
[`(,syntax-body ,body [`(,syntax-body ,body
,requires ,syntax-requires ,template-requires ,label-requires ,requires ,syntax-requires ,template-requires ,label-requires
,more-requires-count . ,more-requires) ,more-requires-count . ,more-requires)
@ -241,34 +241,31 @@
prefix (let loop ([l phase-data]) prefix (let loop ([l phase-data])
(if (null? l) (if (null? l)
null null
(let ([num-vars (list-ref l 7)] (let ([num-vars (list-ref l 6)]
[ps (for/list ([name (in-vector (list-ref l 6))] [ps (for/list ([name (in-vector (list-ref l 5))]
[src (in-vector (list-ref l 5))] [src (in-vector (list-ref l 4))]
[src-name (in-vector (list-ref l 4))] [src-name (in-vector (list-ref l 3))]
[nom-src (or (list-ref l 3) [nom-src (or (list-ref l 2)
(in-cycle (in-value #f)))] (in-cycle (in-value #f)))]
[src-phase (or (list-ref l 2) [src-phase (or (list-ref l 1)
(in-cycle (in-value #f)))] (in-cycle (in-value #f)))]
[protected? (or (case (car l) [protected? (or (case (car l)
[(0) protects] [(0) protects]
[(1) et-protects] [(1) et-protects]
[else #f]) [else #f])
(in-cycle (in-value #f)))] (in-cycle (in-value #f)))])
[insp (or (list-ref l 1)
(in-cycle (in-value #f)))])
(make-provided name src src-name (make-provided name src src-name
(or nom-src src) (or nom-src src)
(if src-phase 1 0) (if src-phase 1 0)
protected? protected?))])
insp))])
(if (null? ps) (if (null? ps)
(loop (list-tail l 9)) (loop (list-tail l 8))
(cons (cons
(list (list
(car l) (car l)
(take ps num-vars) (take ps num-vars)
(drop ps num-vars)) (drop ps num-vars))
(loop (list-tail l 9))))))) (loop (list-tail l 8)))))))
(list* (list*
(cons 0 requires) (cons 0 requires)
(cons 1 syntax-requires) (cons 1 syntax-requires)
@ -527,20 +524,6 @@
(define (decode-mark-map alist) (define (decode-mark-map alist)
alist) alist)
(define marks-memo (make-memo))
(define (decode-marks cp ms)
(with-memo marks-memo ms
(match ms
[#f #f]
[(list* #f (? number? symref) alist)
(make-certificate:ref
(symtab-lookup cp symref)
(decode-mark-map alist))]
[(list* (? list? nested) alist)
(make-certificate:nest (decode-mark-map nested) (decode-mark-map alist))]
[alist
(make-certificate:plain (decode-mark-map alist))])))
(define stx-memo (make-memo)) (define stx-memo (make-memo))
; XXX More memo use ; XXX More memo use
(define (decode-stx cp v) (define (decode-stx cp v)
@ -548,15 +531,15 @@
(if (integer? v) (if (integer? v)
(unmarshal-stx-get/decode cp v decode-stx) (unmarshal-stx-get/decode cp v decode-stx)
(let loop ([v v]) (let loop ([v v])
(let-values ([(cert-marks v encoded-wraps) (let-values ([(tamper-status v encoded-wraps)
(match v (match v
[`#((,datum . ,wraps) ,cert-marks) (values cert-marks datum wraps)] [`#((,datum . ,wraps)) (values 'tainted datum wraps)]
[`(,datum . ,wraps) (values #f datum wraps)] [`#((,datum . ,wraps) #f) (values 'armed datum wraps)]
[`(,datum . ,wraps) (values 'clean datum wraps)]
[else (error 'decode-wraps "bad datum+wrap: ~.s" v)])]) [else (error 'decode-wraps "bad datum+wrap: ~.s" v)])])
(let* ([wraps (decode-wraps cp encoded-wraps)] (let* ([wraps (decode-wraps cp encoded-wraps)]
[marks (decode-marks cp cert-marks)]
[wrapped-memo (make-memo)] [wrapped-memo (make-memo)]
[add-wrap (lambda (v) (with-memo wrapped-memo v (make-wrapped v wraps marks)))]) [add-wrap (lambda (v) (with-memo wrapped-memo v (make-wrapped v wraps tamper-status)))])
(cond (cond
[(pair? v) [(pair? v)
(if (eq? #t (car v)) (if (eq? #t (car v))
@ -652,7 +635,7 @@
[(box? a) [(box? a)
(match (unbox a) (match (unbox a)
[(list (? symbol?) ...) (make-prune (unbox a))] [(list (? symbol?) ...) (make-prune (unbox a))]
[`#(,amt ,src ,dest #f) [`#(,amt ,src ,dest #f #f)
(make-phase-shift amt (make-phase-shift amt
(parse-module-path-index cp src) (parse-module-path-index cp src)
(parse-module-path-index cp dest))] (parse-module-path-index cp dest))]

15
collects/compiler/zo-structs.rkt
View File

@ -57,21 +57,11 @@
(define mark-map? (define mark-map?
(alist/c number? module-path-index?) (alist/c number? module-path-index?)
#;(hash/c number? module-path-index?)) #;(hash/c number? module-path-index?))
(define-form-struct certificate ())
(define-form-struct (certificate:nest certificate)
([nested mark-map?]
[map mark-map?]))
(define-form-struct (certificate:ref certificate)
([val any/c]
[map mark-map?]))
(define-form-struct (certificate:plain certificate)
([map mark-map?]))
(define-form-struct wrap ()) (define-form-struct wrap ())
(define-form-struct wrapped ([datum any/c] (define-form-struct wrapped ([datum any/c]
[wraps (listof wrap?)] [wraps (listof wrap?)]
[certs (or/c certificate? #f)])) [tamper-status (or/c 'clean 'armed 'tainted)]))
;; In stxs of prefix: ;; In stxs of prefix:
(define-form-struct stx ([encoded wrapped?])) (define-form-struct stx ([encoded wrapped?]))
@ -91,8 +81,7 @@
[src-name symbol?] [src-name symbol?]
[nom-src any/c] ; should be (or/c module-path-index? #f) [nom-src any/c] ; should be (or/c module-path-index? #f)
[src-phase (or/c 0 1)] [src-phase (or/c 0 1)]
[protected? boolean?] [protected? boolean?]))
[insp (or/c boolean? void?)]))
(define-form-struct (toplevel expr) ([depth exact-nonnegative-integer?] (define-form-struct (toplevel expr) ([depth exact-nonnegative-integer?]
[pos exact-nonnegative-integer?] [pos exact-nonnegative-integer?]

24
collects/scribblings/raco/zo-struct.scrbl
View File

@ -204,8 +204,7 @@ structures that are produced by @racket[zo-parse] and consumed by
[src-name symbol?] [src-name symbol?]
[nom-mod (or/c module-path-index? #f)] [nom-mod (or/c module-path-index? #f)]
[src-phase (or/c 0 1)] [src-phase (or/c 0 1)]
[protected? boolean?] [protected? boolean?])]{
[insp (or #t #f void?)])]{
Describes an individual provided identifier within a @racket[mod] Describes an individual provided identifier within a @racket[mod]
instance.} instance.}
@ -462,28 +461,11 @@ structures that are produced by @racket[zo-parse] and consumed by
@defstruct+[(wrapped zo) @defstruct+[(wrapped zo)
([datum any/c] ([datum any/c]
[wraps (listof wrap?)] [wraps (listof wrap?)]
[certs (or/c certificate? #f)])]{ [tamper-status (or/c 'clean 'armed 'tainted)])]{
Represents a syntax object, where @racket[wraps] contain the lexical Represents a syntax object, where @racket[wraps] contain the lexical
information and @racket[certs] is certificate information. When the information and @racket[tamper-status] is taint information. When the
@racket[datum] part is itself compound, its pieces are wrapped, too.} @racket[datum] part is itself compound, its pieces are wrapped, too.}
@defstruct+[(certificate zo) ()]{
A supertype for syntax certificates.}
@defstruct+[(certificate:nest certificate)
([nested (listof number? module-path-index? ...)]
[map (listof number? module-path-index? ...)])]{
A nested certificate.}
@defstruct+[(certificate:ref certificate)
([val any/c]
[map (listof number? module-path-index? ...)])]{
A reference certificate.}
@defstruct+[(certificate:plain certificate)
([map (listof number? module-path-index? ...)])]{
A plain certificate.}
@defstruct+[(wrap zo) ()]{ @defstruct+[(wrap zo) ()]{
A supertype for lexical-information elements.} A supertype for lexical-information elements.}