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)])
(match wrap
[(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?))
(define encoded-kind (eq? kind 'marked))
(define encoded-unmarshals (map encode-all-from-module unmarshals))
@ -343,18 +343,9 @@
(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)
(match w
[(struct wrapped (datum wraps certs))
[(struct wrapped (datum wraps tamper-status))
(let* ([enc-datum
(match datum
[(cons a b)
@ -391,9 +382,10 @@
[_ datum])]
[p (cons enc-datum
(encode-wraps wraps))])
(if certs
(vector p (encode-certs certs))
p))]))
(case tamper-status
[(clean) p]
[(tainted) (vector p)]
[(armed) (vector p #f)]))]))
(define-struct out (s shared-index shared-unsee encoded-wraps))
(define (out-shared v out k)
@ -887,7 +879,6 @@
(let ([phase (car l)]
[all (append (cadr l) (caddr l))])
(list phase
(list->vector/#f #f (map provided-insp all))
(list->vector/#f 0 (map (lambda (p) (= 1 (provided-src-phase p)))
all))
(list->vector/#f #f (map (lambda (p)

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

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

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

@ -57,21 +57,11 @@
(define mark-map?
(alist/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 wrapped ([datum any/c]
[wraps (listof wrap?)]
[certs (or/c certificate? #f)]))
[tamper-status (or/c 'clean 'armed 'tainted)]))
;; In stxs of prefix:
(define-form-struct stx ([encoded wrapped?]))
@ -91,8 +81,7 @@
[src-name symbol?]
[nom-src any/c] ; should be (or/c module-path-index? #f)
[src-phase (or/c 0 1)]
[protected? boolean?]
[insp (or/c boolean? void?)]))
[protected? boolean?]))
(define-form-struct (toplevel expr) ([depth 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?]
[nom-mod (or/c module-path-index? #f)]
[src-phase (or/c 0 1)]
[protected? boolean?]
[insp (or #t #f void?)])]{
[protected? boolean?])]{
Describes an individual provided identifier within a @racket[mod]
instance.}
@ -462,28 +461,11 @@ structures that are produced by @racket[zo-parse] and consumed by
@defstruct+[(wrapped zo)
([datum any/c]
[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
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.}
@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) ()]{
A supertype for lexical-information elements.}