add structures, decoding, and encoding for zo syntax objects
This commit is contained in:
Matthew Flatt
parent
56a8886525
commit
3d46070994
|
|
@ -116,6 +116,16 @@
|
|||
(for/list ([(k v) (in-hash e)])
|
||||
(cons (loop k) (loop v)))))
|
||||
ph]
|
||||
[(prefab-struct-key e)
|
||||
=> (lambda (k)
|
||||
(define ph (make-placeholder #f))
|
||||
(hash-set! ht e ph)
|
||||
(placeholder-set! ph
|
||||
(apply make-prefab-struct
|
||||
k
|
||||
(map loop
|
||||
(cdr (vector->list (struct->vector e))))))
|
||||
ph)]
|
||||
[else
|
||||
e])))
|
||||
(define l (make-reader-graph (cons main mconses)))
|
||||
|
|
@ -174,7 +184,7 @@
|
|||
(map (lambda (stx id)
|
||||
`(define ,id ,(if stx
|
||||
`(#%decode-syntax
|
||||
,(decompile-stx (stx-encoded stx) stx-ht))
|
||||
,(decompile-stx (stx-content stx) stx-ht))
|
||||
#f)))
|
||||
stxs stx-ids))))]
|
||||
[else (error 'decompile-prefix "huh?: ~e" a-prefix)]))
|
||||
|
|
@ -184,7 +194,7 @@
|
|||
(let ([p (mcons #f #f)])
|
||||
(hash-set! stx-ht stx p)
|
||||
(match stx
|
||||
[(wrapped datum wraps tamper-status)
|
||||
[(stx-obj datum wrap tamper-status)
|
||||
(set-mcar! p (case tamper-status
|
||||
[(clean) 'wrap]
|
||||
[(tainted) 'wrap-tainted]
|
||||
|
|
@ -207,7 +217,7 @@
|
|||
[(box? datum)
|
||||
(box (decompile-stx (unbox datum) stx-ht))]
|
||||
[else datum])
|
||||
wraps))
|
||||
wrap))
|
||||
p]))))
|
||||
|
||||
(define (mpi->string modidx)
|
||||
|
|
@ -231,7 +241,7 @@
|
|||
(quote internal-context
|
||||
,(if (stx? internal-context)
|
||||
`(#%decode-syntax
|
||||
,(decompile-stx (stx-encoded internal-context) stx-ht))
|
||||
,(decompile-stx (stx-content internal-context) stx-ht))
|
||||
internal-context))
|
||||
(quote bindings ,(for/hash ([(phase ht) (in-hash binding-names)])
|
||||
(values phase
|
||||
|
|
@ -240,7 +250,7 @@
|
|||
(if (eq? id #t)
|
||||
#t
|
||||
`(#%decode-syntax
|
||||
,(decompile-stx (stx-encoded id) stx-ht))))))))
|
||||
,(decompile-stx (stx-content id) stx-ht))))))))
|
||||
(quote language-info ,lang-info)
|
||||
,@(if (null? flags) '() (list `(quote ,flags)))
|
||||
,@(let ([l (apply
|
||||
|
|
|
|||
|
|
@ -17,7 +17,7 @@
|
|||
(define-values (reqs new-forms)
|
||||
(partition req? (splice-forms form)))
|
||||
(define requires
|
||||
(map (compose ->module-path-index wrapped-datum stx-encoded req-reqs) reqs))
|
||||
(map (compose ->module-path-index stx-obj-datum stx-content req-reqs) reqs))
|
||||
(make-compilation-top
|
||||
0
|
||||
(make-prefix 0 (list #f) empty)
|
||||
|
|
|
|||
|
|
@ -197,13 +197,13 @@
|
|||
empty
|
||||
(begin
|
||||
(hash-set! REQUIRED ct #t)
|
||||
(list (make-req (make-stx (make-wrapped ct empty 'clean)) (make-toplevel 0 0 #f #f)))))]
|
||||
(list (make-req (make-stx (make-stx-obj ct (wrap empty empty empty) 'clean)) (make-toplevel 0 0 #f #f)))))]
|
||||
[(module-path-index? ct)
|
||||
(if (hash-has-key? REQUIRED ct)
|
||||
empty
|
||||
(begin
|
||||
(hash-set! REQUIRED ct #t)
|
||||
(list (make-req (make-stx (make-wrapped ct empty 'clean)) (make-toplevel 0 0 #f #f)))))]
|
||||
(list (make-req (make-stx (make-stx-obj ct (wrap empty empty empty) 'clean)) (make-toplevel 0 0 #f #f)))))]
|
||||
[(not ct)
|
||||
empty]
|
||||
[(@phase? ct)
|
||||
|
|
|
|||
|
|
@ -28,16 +28,16 @@
|
|||
(test
|
||||
(roundtrip
|
||||
(compilation-top 0
|
||||
(prefix 0 empty empty)
|
||||
(prefix 0 empty empty 'insp0)
|
||||
(list 1 (list 2 3) (list 2 3) 4 5)))
|
||||
|
||||
(roundtrip
|
||||
(compilation-top 0
|
||||
(prefix 1 empty empty)
|
||||
(prefix 1 empty empty 'insp0)
|
||||
(list (lam 'proc null 0 null #f #(0) '(val/ref) (set 0) 3 1))))
|
||||
(roundtrip
|
||||
(compilation-top 0
|
||||
(prefix 1 empty empty)
|
||||
(prefix 1 empty empty 'insp0)
|
||||
(list (lam 'proc null 0 null #f #(0) '(val/ref) #f 3 1))))
|
||||
|
||||
#;(roundtrip
|
||||
|
|
@ -94,23 +94,23 @@
|
|||
|
||||
(roundtrip
|
||||
(compilation-top 0
|
||||
(prefix 0 empty empty)
|
||||
(prefix 0 empty empty 'insp0)
|
||||
(current-directory)))
|
||||
|
||||
(roundtrip
|
||||
(compilation-top 0
|
||||
(prefix 0 empty empty)
|
||||
(prefix 0 empty empty 'insp0)
|
||||
(list (current-directory))))
|
||||
|
||||
(roundtrip
|
||||
(compilation-top
|
||||
0
|
||||
(prefix 0 empty empty)
|
||||
(prefix 0 empty empty 'insp0)
|
||||
(cons #hash()
|
||||
#hash())))
|
||||
|
||||
(roundtrip
|
||||
(compilation-top
|
||||
0
|
||||
(prefix 0 empty empty)
|
||||
(prefix 0 empty empty 'insp0)
|
||||
#hash())))
|
||||
|
|
|
|||
|
|
@ -20,6 +20,8 @@
|
|||
|
||||
(struct not-ready ())
|
||||
|
||||
(struct encoded-scope ([content #:mutable]) #:prefab)
|
||||
|
||||
(define (zo-marshal top)
|
||||
(define bs (open-output-bytes))
|
||||
(zo-marshal-to top bs)
|
||||
|
|
@ -142,8 +144,10 @@
|
|||
|
||||
(define (zo-marshal-top-to top outp)
|
||||
|
||||
; XXX: wraps were encoded in traverse, now needs to be handled when writing
|
||||
(define wrapped (make-hash))
|
||||
; For detecting sharing in wraps:
|
||||
(define stx-objs (make-hasheq))
|
||||
(define wraps (make-hasheq))
|
||||
(define hash-consed (make-hash))
|
||||
|
||||
; (obj -> (or pos #f)) output-port -> number
|
||||
; writes top to outp using shared-obj-pos to determine symref
|
||||
|
|
@ -153,7 +157,8 @@
|
|||
(match top
|
||||
[(compilation-top max-let-depth prefix form)
|
||||
(list* max-let-depth prefix (protect-quote form))]))
|
||||
(out-anything ct (make-out outp shared-obj-pos shared-obj-unsee wrapped))
|
||||
(out-anything ct (make-out outp shared-obj-pos shared-obj-unsee
|
||||
stx-objs wraps hash-consed))
|
||||
(file-position outp))
|
||||
|
||||
; -> vector
|
||||
|
|
@ -227,7 +232,8 @@
|
|||
[i (in-naturals)])
|
||||
(begin0
|
||||
(file-position outp)
|
||||
(out-anything v (make-out outp (shared-obj-pos/modulo-v v) void wrapped))))
|
||||
(out-anything v (make-out outp (shared-obj-pos/modulo-v v) void
|
||||
stx-objs wraps hash-consed))))
|
||||
(file-position outp)))
|
||||
|
||||
; Calculate file positions
|
||||
|
|
@ -336,8 +342,8 @@
|
|||
CPT_DELAY_REF ; XXX unused, but appears to be same as CPT_SYMREF
|
||||
CPT_PREFAB
|
||||
CPT_LET_ONE_UNUSED
|
||||
CPT_MARK
|
||||
CPT_ROOT_MARK
|
||||
CPT_SCOPE
|
||||
CPT_ROOT_SCOPE
|
||||
CPT_SHARED)
|
||||
|
||||
(define CPT_SMALL_NUMBER_START 39)
|
||||
|
|
@ -383,68 +389,23 @@
|
|||
#f
|
||||
#f))
|
||||
|
||||
(define (encode-module-bindings module-bindings)
|
||||
(define encode-nominal-path
|
||||
(match-lambda
|
||||
[(struct simple-nominal-path (value))
|
||||
value]
|
||||
[(struct imported-nominal-path (value import-phase))
|
||||
(cons value import-phase)]
|
||||
[(struct phased-nominal-path (value import-phase phase))
|
||||
(cons value (cons import-phase phase))]))
|
||||
(define encoded-bindings (make-vector (* (length module-bindings) 2)))
|
||||
(for ([i (in-naturals)]
|
||||
[(k v) (in-dict module-bindings)])
|
||||
(vector-set! encoded-bindings (* i 2) k)
|
||||
(vector-set! encoded-bindings (add1 (* i 2))
|
||||
(match v
|
||||
[(struct simple-module-binding (path))
|
||||
path]
|
||||
[(struct exported-module-binding (path export-name))
|
||||
(cons path export-name)]
|
||||
[(struct nominal-module-binding (path nominal-path))
|
||||
(cons path (encode-nominal-path nominal-path))]
|
||||
[(struct exported-nominal-module-binding (path export-name nominal-path nominal-export-name))
|
||||
(list* path export-name (encode-nominal-path nominal-path) nominal-export-name)]
|
||||
[(struct phased-module-binding (path phase export-name nominal-path nominal-export-name))
|
||||
(list* path phase export-name (encode-nominal-path nominal-path) nominal-export-name)])))
|
||||
encoded-bindings)
|
||||
|
||||
(define (encode-all-from-module afm)
|
||||
(match afm
|
||||
[(struct all-from-module (path phase src-phase '() #f '()))
|
||||
(list* path phase src-phase)]
|
||||
[(struct all-from-module (path phase src-phase '() #f context))
|
||||
(list* path phase context src-phase)]
|
||||
[(struct all-from-module (path phase src-phase exns prefix '()))
|
||||
(list* path phase src-phase exns prefix)]))
|
||||
|
||||
(define (encode-wraps wraps)
|
||||
#f)
|
||||
|
||||
(define (encode-mark-map mm)
|
||||
mm
|
||||
#;(for/fold ([l empty])
|
||||
([(k v) (in-hash ht)])
|
||||
(list* k v l)))
|
||||
|
||||
(define-struct protected-symref (val))
|
||||
|
||||
(define (encode-wrapped w)
|
||||
(define (encode-stx-obj w wraps-ht)
|
||||
(match w
|
||||
[(struct wrapped (datum wraps tamper-status))
|
||||
[(struct stx-obj (datum wraps tamper-status))
|
||||
(let* ([enc-datum
|
||||
(match datum
|
||||
[(cons a b)
|
||||
(let ([p (cons (encode-wrapped a)
|
||||
(let ([p (cons (encode-stx-obj a wraps-ht)
|
||||
(let bloop ([b b])
|
||||
(match b
|
||||
['() null]
|
||||
[(cons b1 b2)
|
||||
(cons (encode-wrapped b1)
|
||||
(cons (encode-stx-obj b1 wraps-ht)
|
||||
(bloop b2))]
|
||||
[else
|
||||
(encode-wrapped b)])))]
|
||||
(encode-stx-obj b wraps-ht)])))]
|
||||
; XXX Cylic list error possible
|
||||
[len (let loop ([datum datum][len 0])
|
||||
(cond
|
||||
|
|
@ -457,24 +418,24 @@
|
|||
(cons len p)
|
||||
p))]
|
||||
[(box x)
|
||||
(box (encode-wrapped x))]
|
||||
(box (encode-stx-obj x wraps-ht))]
|
||||
[(? vector? v)
|
||||
(vector-map encode-wrapped v)]
|
||||
(vector-map (lambda (e) (encode-stx-obj e wraps-ht)) v)]
|
||||
[(? prefab-struct-key)
|
||||
(define l (vector->list (struct->vector datum)))
|
||||
(apply
|
||||
make-prefab-struct
|
||||
(car l)
|
||||
(map encode-wrapped (cdr l)))]
|
||||
(map (lambda (e) (encode-stx-obj e wraps-ht)) (cdr l)))]
|
||||
[_ datum])]
|
||||
[p (cons enc-datum
|
||||
(encode-wraps wraps))])
|
||||
(encode-wrap wraps wraps-ht))])
|
||||
(case tamper-status
|
||||
[(clean) 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 stx-objs wraps hash-consed))
|
||||
(define (out-shared v out k)
|
||||
(if (shareable? v)
|
||||
(let ([v ((out-shared-index out) v)])
|
||||
|
|
@ -523,7 +484,9 @@
|
|||
|
||||
(define (shareable? v)
|
||||
(define never-share-this?
|
||||
(or-pred? v char? maybe-same-as-fixnum? empty? boolean? void? hash?))
|
||||
(or-pred? v char? maybe-same-as-fixnum? empty? boolean? void? hash?
|
||||
;; For root scope:
|
||||
scope?))
|
||||
(define always-share-this?
|
||||
(or-pred? v closure?))
|
||||
(or always-share-this?
|
||||
|
|
@ -584,6 +547,8 @@
|
|||
(out-byte CPT_FALSE out)]
|
||||
[(? void?)
|
||||
(out-byte CPT_VOID out)]
|
||||
[(? (lambda (s) (and (scope? s) (eq? (scope-name s) 'root))))
|
||||
(out-byte CPT_ROOT_SCOPE out)]
|
||||
[(struct module-variable (modidx sym pos phase constantness))
|
||||
(define (to-sym n) (string->symbol (format "struct~a" n)))
|
||||
(out-byte CPT_MODULE_VAR out)
|
||||
|
|
@ -917,11 +882,23 @@
|
|||
(out-anything base out)
|
||||
(unless (or name base)
|
||||
(out-anything (module-path-index-submodule v) out)))]
|
||||
[(stx encoded)
|
||||
[(stx content)
|
||||
(out-byte CPT_STX out)
|
||||
(out-anything encoded out)]
|
||||
[(? wrapped?)
|
||||
(out-anything (lookup-encoded-wrapped v out) out)]
|
||||
;; The core Racket printer currently records more sharing
|
||||
;; by ensureing that list tails are shared, while the printer
|
||||
;; here detects sharing only at the start of a list. That
|
||||
;; doesn't seem to matter much. Meanwhile, we ensure that
|
||||
;; as much sharing as possible is present before printing.
|
||||
(out-anything content out)]
|
||||
[(encoded-scope content)
|
||||
(out-byte CPT_SCOPE out)
|
||||
;; The `out-shared` wrapper already called `((out-shared-index out) v)`
|
||||
;; once, so `pos` will defintely be a number:
|
||||
(let ([pos ((out-shared-index out) v)])
|
||||
(out-number pos out))
|
||||
(out-anything (share-everywhere content out) out)]
|
||||
[(? stx-obj?)
|
||||
(out-anything (lookup-encoded-stx-obj v out) out)]
|
||||
[(? prefab-struct-key)
|
||||
(define pre-v (struct->vector v))
|
||||
(vector-set! pre-v 0 (prefab-struct-key v))
|
||||
|
|
@ -1072,10 +1049,10 @@
|
|||
[l (cons (if (pair? name) (cdr name) null) l)])
|
||||
l)]))
|
||||
|
||||
(define (lookup-encoded-wrapped w out)
|
||||
(hash-ref! (out-encoded-wraps out) w
|
||||
(λ ()
|
||||
(encode-wrapped w))))
|
||||
(define (lookup-encoded-stx-obj w out)
|
||||
(hash-ref! (out-stx-objs out) w
|
||||
(λ ()
|
||||
(encode-stx-obj w (out-wraps out)))))
|
||||
|
||||
(define (pack-binding-names binding-names)
|
||||
(define (ht-to-vector ht)
|
||||
|
|
@ -1178,6 +1155,237 @@
|
|||
(find-relative-path r v)
|
||||
v)))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
;; We want to hash-cons syntax-object wraps, but a normal `equal?`-based
|
||||
;; table would equate different "self" modidxes that we need to keep
|
||||
;; separate. So, roll a `simple-equal?` that inspects wraps. We don't
|
||||
;; have to deal with cycles, since cycles would always go through a scope,
|
||||
;; and we recur into scopes.
|
||||
|
||||
(struct modidx-must-be-eq (content)
|
||||
#:property prop:equal+hash
|
||||
(list (lambda (a b eql?)
|
||||
(simple-equal? (modidx-must-be-eq-content a)
|
||||
(modidx-must-be-eq-content b)))
|
||||
(lambda (a h) (h (modidx-must-be-eq-content a)))
|
||||
(lambda (a h) (h (modidx-must-be-eq-content a)))))
|
||||
|
||||
(define (simple-equal? a b)
|
||||
(cond
|
||||
[(eqv? a b) #t]
|
||||
[(pair? a)
|
||||
(and (pair? b)
|
||||
(simple-equal? (car a) (car b))
|
||||
(simple-equal? (cdr a) (cdr b)))]
|
||||
[(vector? a)
|
||||
(and (vector? b)
|
||||
(= (vector-length a) (vector-length b))
|
||||
(for/and ([ae (in-vector a)]
|
||||
[be (in-vector b)])
|
||||
(simple-equal? ae be)))]
|
||||
[(box? a)
|
||||
(and (box? b)
|
||||
(simple-equal? (unbox a) (unbox b)))]
|
||||
[else #f]))
|
||||
|
||||
(define (share-everywhere v out)
|
||||
(hash-ref! (out-hash-consed out)
|
||||
(modidx-must-be-eq v)
|
||||
(lambda ()
|
||||
(cond
|
||||
[(pair? v)
|
||||
(cons (share-everywhere (car v) out)
|
||||
(share-everywhere (cdr v) out))]
|
||||
[(vector? v)
|
||||
(for/vector #:length (vector-length v) ([e (in-vector v)])
|
||||
(share-everywhere e out))]
|
||||
[(box? v)
|
||||
(box (share-everywhere (unbox v) out))]
|
||||
[else v]))))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define (encode-wrap w ht)
|
||||
(hash-ref! ht w
|
||||
(lambda ()
|
||||
(vector (map-encode encode-shift (wrap-shifts w) ht)
|
||||
(encode-scope-list (wrap-simple-scopes w) ht)
|
||||
(map-encode encode-multi-scope (wrap-multi-scopes w) ht)))))
|
||||
|
||||
(define (map-encode encode l ht)
|
||||
(cond
|
||||
[(null? l) l]
|
||||
[else
|
||||
(hash-ref! ht l
|
||||
(lambda ()
|
||||
(cons (encode (car l) ht)
|
||||
(map-encode encode (cdr l) ht))))]))
|
||||
|
||||
(define (encode-shift s ht)
|
||||
(hash-ref! ht s
|
||||
(lambda ()
|
||||
(if (module-shift-from-inspector-desc s)
|
||||
(vector (module-shift-to s)
|
||||
(module-shift-from s)
|
||||
(module-shift-from-inspector-desc s)
|
||||
(module-shift-to-inspector-desc s))
|
||||
(vector (module-shift-to s)
|
||||
(module-shift-from s))))))
|
||||
|
||||
(define (encode-scope s ht)
|
||||
(if (eq? 'root (scope-name s))
|
||||
s
|
||||
(hash-ref ht s
|
||||
(lambda ()
|
||||
(define es (encoded-scope #f))
|
||||
(hash-set! ht s es)
|
||||
(define kind
|
||||
(case (scope-kind s)
|
||||
[(module) (if (scope-multi-owner s)
|
||||
1
|
||||
0)]
|
||||
[(macro) 2]
|
||||
[(local) 3]
|
||||
[(intdef) 4]
|
||||
[else 5]))
|
||||
(cond
|
||||
[(and (null? (scope-bindings s))
|
||||
(null? (scope-bulk-bindings s)))
|
||||
(set-encoded-scope-content! es kind)]
|
||||
[else
|
||||
(define binding-table
|
||||
(for/fold ([bt (hasheq)]) ([b (in-list (scope-bindings s))])
|
||||
(hash-set bt
|
||||
(car b)
|
||||
(cons (cons (encode-scope-list (cadr b) ht)
|
||||
(encode-binding (caddr b) (car b) ht))
|
||||
(hash-ref bt (car b) null)))))
|
||||
(define bindings
|
||||
(list->vector
|
||||
(apply
|
||||
append
|
||||
(sort (hash-map binding-table list)
|
||||
symbol<?
|
||||
#:key car))))
|
||||
(set-encoded-scope-content!
|
||||
es
|
||||
(cons kind
|
||||
(append (map-encode
|
||||
encode-bulk-binding
|
||||
(scope-bulk-bindings s)
|
||||
ht)
|
||||
bindings)))])
|
||||
es))))
|
||||
|
||||
(define (encode-scope-list l ht)
|
||||
(map-encode encode-scope
|
||||
(sort l > #:key (lambda (s)
|
||||
(if (eq? 'root (scope-name s))
|
||||
-1
|
||||
(scope-name s))))
|
||||
ht))
|
||||
|
||||
(define (encode-multi-scope ms+phase ht)
|
||||
(define ms (car ms+phase))
|
||||
(cons (hash-ref ht ms
|
||||
(lambda ()
|
||||
(define v (make-vector (add1 (* 2 (length (multi-scope-scopes ms))))))
|
||||
(hash-set! ht ms v)
|
||||
(vector-copy!
|
||||
v
|
||||
0
|
||||
(list->vector
|
||||
(append (apply
|
||||
append
|
||||
(for/list ([e (in-list (multi-scope-scopes ms))])
|
||||
(list (car e)
|
||||
(encode-scope (cadr e) ht))))
|
||||
(list (multi-scope-src-name ms)))))
|
||||
v))
|
||||
(cadr ms+phase)))
|
||||
|
||||
(define (encode-binding b name ht)
|
||||
(match b
|
||||
[(free-id=?-binding base id)
|
||||
(hash-ref ht b
|
||||
(lambda ()
|
||||
(match b
|
||||
[(free-id=?-binding base id)
|
||||
(define bx (box #f))
|
||||
(hash-set! ht b bx)
|
||||
(set-box! bx
|
||||
(cons (encode-binding base name ht)
|
||||
(cons (stx-obj-datum id)
|
||||
(stx-obj-wrap id))))])))]
|
||||
[_
|
||||
(hash-ref! ht b
|
||||
(lambda ()
|
||||
(match b
|
||||
[(local-binding name)
|
||||
name]
|
||||
[(module-binding encoded)
|
||||
encoded]
|
||||
[(? decoded-module-binding?)
|
||||
(encode-module-binding b name ht)])))]))
|
||||
|
||||
|
||||
(define (encode-module-binding b name ht)
|
||||
(hash-ref! ht (cons name b)
|
||||
(lambda ()
|
||||
(match b
|
||||
[(decoded-module-binding path export-name phase
|
||||
nominal-path nominal-export-name nominal-phase
|
||||
import-phase inspector-desc)
|
||||
(define l
|
||||
(cond
|
||||
[(and (eq? path nominal-path)
|
||||
(eq? export-name nominal-export-name)
|
||||
(eqv? phase 0)
|
||||
(eqv? import-phase 0)
|
||||
(eqv? nominal-phase phase))
|
||||
(if (eq? name export-name)
|
||||
path
|
||||
(cons path export-name))]
|
||||
[(and (eq? export-name nominal-export-name)
|
||||
(eq? name export-name)
|
||||
(eqv? 0 phase)
|
||||
(eqv? import-phase 0)
|
||||
(eqv? nominal-phase phase))
|
||||
(cons path nominal-path)]
|
||||
[else
|
||||
(define nom-mod+phase
|
||||
(if (eqv? nominal-phase phase)
|
||||
(if (eqv? 0 import-phase)
|
||||
nominal-path
|
||||
(cons nominal-path import-phase))
|
||||
(cons nominal-path (cons import-phase nominal-phase))))
|
||||
(define l (list* export-name nom-mod+phase nominal-export-name))
|
||||
(if (zero? phase)
|
||||
l
|
||||
(cons phase l))]))
|
||||
(if inspector-desc
|
||||
(cons inspector-desc l)
|
||||
l)]))))
|
||||
|
||||
(define (encode-bulk-binding p ht)
|
||||
(cons (encode-scope-list (car p) ht)
|
||||
(encode-all-from-module (cadr p) ht)))
|
||||
|
||||
(define (encode-all-from-module b ht)
|
||||
(hash-ref! ht b
|
||||
(lambda ()
|
||||
(match b
|
||||
[(all-from-module path phase src-phase inspector-desc exceptions prefix)
|
||||
(vector path src-phase
|
||||
(cond
|
||||
[(and (not prefix) (null? exceptions))
|
||||
phase]
|
||||
[(not prefix)
|
||||
(cons phase (list->vector exceptions))]
|
||||
[(null? exceptions)
|
||||
(cons phase prefix)]
|
||||
[else
|
||||
(cons phase (cons (list->vector exceptions) prefix))])
|
||||
inspector-desc)]))))
|
||||
|
||||
|
|
|
|||
|
|
@ -7,28 +7,10 @@
|
|||
racket/dict
|
||||
racket/set)
|
||||
|
||||
(provide zo-parse)
|
||||
(provide zo-parse
|
||||
decode-module-binding)
|
||||
(provide (all-from-out compiler/zo-structs))
|
||||
|
||||
#| Unresolved Issues
|
||||
|
||||
The order of indirect-et-provides, indirect-syntax-provides, indirect-provides was changed, is that okay?
|
||||
|
||||
orig-port of cport struct is never used, is it needed?
|
||||
|
||||
Lines 628, 630 seem to be only for debugging and should probably throw errors
|
||||
|
||||
vector and pair cases of decode-wraps seem to do different things from the corresponding C code
|
||||
|
||||
Line 816: This should be an eqv placeholder (but they don't exist)
|
||||
|
||||
Line 634: Export registry is always matched as false, but might not be
|
||||
|
||||
What are the real differences between the module-binding cases?
|
||||
|
||||
I think parse-module-path-index was only used for debugging, so it is short-circuited now
|
||||
|
||||
|#
|
||||
;; ----------------------------------------
|
||||
;; Bytecode unmarshalers for various forms
|
||||
|
||||
|
|
@ -506,8 +488,8 @@
|
|||
[33 delayed]
|
||||
[34 prefab]
|
||||
[35 let-one-unused]
|
||||
[36 mark]
|
||||
[37 root-mark]
|
||||
[36 scope]
|
||||
[37 root-scope]
|
||||
[38 shared]
|
||||
[39 62 small-number]
|
||||
[62 80 small-symbol]
|
||||
|
|
@ -521,6 +503,8 @@
|
|||
[249 small-application3]
|
||||
[247 255 small-application]))
|
||||
|
||||
(define root-scope (scope 'root 'module null null #f))
|
||||
|
||||
;; To accelerate cpt-table lookup, we flatten out the above
|
||||
;; list into a vector:
|
||||
(define cpt-table (make-vector 256 #f))
|
||||
|
|
@ -607,7 +591,10 @@
|
|||
(define-syntax-rule (with-memo mt arg body ...)
|
||||
(with-memo* mt arg (λ () body ...)))
|
||||
|
||||
(define (decode-stx cp v)
|
||||
;; placeholder for a `scope` decoded in a second pass:
|
||||
(struct encoded-scope (content) #:prefab)
|
||||
|
||||
(define (decode-wrapped cp v)
|
||||
(let loop ([v v])
|
||||
(let-values ([(tamper-status v encoded-wraps)
|
||||
(match v
|
||||
|
|
@ -615,9 +602,8 @@
|
|||
[`#((,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)]
|
||||
[wrapped-memo (make-memo)]
|
||||
[add-wrap (lambda (v) (with-memo wrapped-memo v (make-wrapped v wraps tamper-status)))])
|
||||
(let* ([wrapped-memo (make-memo)]
|
||||
[add-wrap (lambda (v) (with-memo wrapped-memo v (make-stx-obj v encoded-wraps tamper-status)))])
|
||||
(cond
|
||||
[(pair? v)
|
||||
(if (eq? #t (car v))
|
||||
|
|
@ -670,35 +656,6 @@
|
|||
(map loop (struct->list v)))))]
|
||||
[else (add-wrap v)])))))
|
||||
|
||||
(define (afm-context? v)
|
||||
(or (and (list? v) (andmap exact-integer? v))
|
||||
(and (vector? v)
|
||||
(= 2 (vector-length v))
|
||||
(list? (vector-ref v 0))
|
||||
(andmap exact-integer? (vector-ref v 0)))))
|
||||
|
||||
(define all-from-module-memo (make-memo))
|
||||
(define (decode-all-from-module cp afm)
|
||||
(define (phase? v)
|
||||
(or (number? v) (not v)))
|
||||
(with-memo all-from-module-memo afm
|
||||
(match afm
|
||||
[(list* path (? phase? phase) (? phase? src-phase) (list exn ...) prefix)
|
||||
(make-all-from-module
|
||||
(parse-module-path-index cp path)
|
||||
phase src-phase exn prefix null)]
|
||||
[(list* path (? phase? phase) (? afm-context? context) (? phase? src-phase))
|
||||
(make-all-from-module
|
||||
(parse-module-path-index cp path)
|
||||
phase src-phase null #f context)]
|
||||
[(list* path (? phase? phase) (? phase? src-phase))
|
||||
(make-all-from-module
|
||||
(parse-module-path-index cp path)
|
||||
phase src-phase null #f null)])))
|
||||
|
||||
(define (decode-wraps cp w)
|
||||
w)
|
||||
|
||||
(define (in-vector* v n)
|
||||
(make-do-sequence
|
||||
(λ ()
|
||||
|
|
@ -709,49 +666,6 @@
|
|||
(λ _ #t)
|
||||
(λ _ #t)))))
|
||||
|
||||
(define nominal-path-memo (make-memo))
|
||||
(define (decode-nominal-path np)
|
||||
(with-memo nominal-path-memo np
|
||||
(match np
|
||||
[(cons nominal-path (cons import-phase nominal-phase))
|
||||
(make-phased-nominal-path nominal-path import-phase nominal-phase)]
|
||||
[(cons nominal-path import-phase)
|
||||
(make-imported-nominal-path nominal-path import-phase)]
|
||||
[nominal-path
|
||||
(make-simple-nominal-path nominal-path)])))
|
||||
|
||||
; XXX Weird test copied from C code. Matthew?
|
||||
(define (nom_mod_p p)
|
||||
(and (pair? p) (not (pair? (cdr p))) (not (symbol? (cdr p)))))
|
||||
|
||||
(define rename-v-memo (make-memo))
|
||||
(define (decode-rename-v v)
|
||||
(with-memo rename-v-memo v
|
||||
(match v
|
||||
[(list-rest path phase export-name nominal-path nominal-export-name)
|
||||
(make-phased-module-binding path
|
||||
phase
|
||||
export-name
|
||||
(decode-nominal-path nominal-path)
|
||||
nominal-export-name)]
|
||||
[(list-rest path export-name nominal-path nominal-export-name)
|
||||
(make-exported-nominal-module-binding path
|
||||
export-name
|
||||
(decode-nominal-path nominal-path)
|
||||
nominal-export-name)]
|
||||
[(cons module-path-index (? nom_mod_p nominal-path))
|
||||
(make-nominal-module-binding module-path-index (decode-nominal-path nominal-path))]
|
||||
[(cons module-path-index export-name)
|
||||
(make-exported-module-binding module-path-index export-name)]
|
||||
[module-path-index
|
||||
(make-simple-module-binding module-path-index)])))
|
||||
|
||||
(define renames-memo (make-memo))
|
||||
(define (decode-renames renames)
|
||||
(with-memo renames-memo renames
|
||||
(for/list ([(k v) (in-vector* renames 2)])
|
||||
(cons k (decode-rename-v v)))))
|
||||
|
||||
(define (parse-module-path-index cp s)
|
||||
s)
|
||||
|
||||
|
|
@ -934,7 +848,7 @@
|
|||
[(marshalled) (read-marshalled (read-compact-number cp) cp)]
|
||||
[(stx)
|
||||
(let ([v (read-compact cp)])
|
||||
(make-stx (decode-stx cp v)))]
|
||||
(make-stx (decode-wrapped cp v)))]
|
||||
[(local local-unbox)
|
||||
(let ([c (read-compact-number cp)]
|
||||
[unbox? (eq? cpt-tag 'local-unbox)])
|
||||
|
|
@ -1027,11 +941,13 @@
|
|||
(read-compact-svector cp (read-compact-number cp))]
|
||||
[(small-svector)
|
||||
(read-compact-svector cp (- ch cpt-start))]
|
||||
[(mark)
|
||||
[(scope)
|
||||
(let ([pos (read-compact-number cp)])
|
||||
(if (zero? pos)
|
||||
(box (read-compact cp))
|
||||
(read-cyclic cp pos 'mark box)))]
|
||||
(encoded-scope (read-compact cp))
|
||||
(read-cyclic cp pos 'scope encoded-scope)))]
|
||||
[(root-scope)
|
||||
root-scope]
|
||||
[(shared)
|
||||
(let ([pos (read-compact-number cp)])
|
||||
(read-cyclic cp pos 'shared))]
|
||||
|
|
@ -1210,7 +1126,299 @@
|
|||
#;(for ([(i v) (in-dict (cport-symtab cp))])
|
||||
(printf "~a = ~a\n" i (placeholder-get v)))
|
||||
(set-cport-pos! cp shared-size)
|
||||
(make-reader-graph (read-marshalled 'compilation-top-type cp)))
|
||||
|
||||
(define decoded-except-for-stx
|
||||
(make-reader-graph (read-marshalled 'compilation-top-type cp)))
|
||||
|
||||
(decode-stxes decoded-except-for-stx))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define (decode-stxes v)
|
||||
;; Walk `v` to find `stx-obj` instances and decode the `wrap` field.
|
||||
;; We do this after building a graph from the input, and `decode-wrap`
|
||||
;; preserves graph structure.
|
||||
(define decode-ht (make-hasheq))
|
||||
(let walk ([p v])
|
||||
(match p
|
||||
[(compilation-top _ pfx c)
|
||||
(struct-copy compilation-top p
|
||||
[prefix (walk pfx)]
|
||||
[code (walk c)])]
|
||||
[(prefix _ _ s _)
|
||||
(struct-copy prefix p [stxs (map walk s)])]
|
||||
[(req rs _)
|
||||
(struct-copy req p
|
||||
[reqs (map walk rs)])]
|
||||
[(? mod?)
|
||||
(struct-copy mod p
|
||||
[prefix (walk (mod-prefix p))]
|
||||
[syntax-bodies
|
||||
(for/list ([e (in-list (mod-syntax-bodies p))])
|
||||
(cons (car e)
|
||||
(map walk (cdr e))))]
|
||||
[internal-context
|
||||
(walk (mod-internal-context p))]
|
||||
[binding-names
|
||||
(for/hash ([(p ht) (in-hash (mod-binding-names p))])
|
||||
(values p
|
||||
(for/hash ([(k v) (in-hash ht)])
|
||||
(values k (walk v)))))]
|
||||
[pre-submodules
|
||||
(map walk (mod-pre-submodules p))]
|
||||
[post-submodules
|
||||
(map walk (mod-post-submodules p))])]
|
||||
[(stx c)
|
||||
(struct-copy stx p [content (walk c)])]
|
||||
[(def-syntaxes _ _ pfx _ _)
|
||||
(struct-copy def-syntaxes p
|
||||
[prefix (walk pfx)])]
|
||||
[(seq-for-syntax _ pfx _ _)
|
||||
(struct-copy seq-for-syntax p
|
||||
[prefix (walk pfx)])]
|
||||
[(stx-obj d w _)
|
||||
(struct-copy stx-obj p
|
||||
[datum (walk d)]
|
||||
[wrap (decode-wrap w decode-ht)])]
|
||||
[(? zo?) p]
|
||||
;; Generic constructors happen inside the `datum` of `stx-obj`,
|
||||
;; for example (with no cycles):
|
||||
[(cons a d)
|
||||
(cons (walk a) (walk d))]
|
||||
[(? vector?)
|
||||
(vector->immutable-vector
|
||||
(for/vector #:length (vector-length p) ([e (in-vector p)])
|
||||
(walk e)))]
|
||||
[(box v)
|
||||
(box-immutable (walk v))]
|
||||
[(? prefab-struct-key)
|
||||
(apply make-prefab-struct
|
||||
(prefab-struct-key p)
|
||||
(cdr (for/list ([e (in-vector (struct->vector p))])
|
||||
(walk e))))]
|
||||
[(? hash?)
|
||||
(cond
|
||||
[(hash-eq? p)
|
||||
(for/hasheq ([(k v) (in-hash p)])
|
||||
(values k (walk v)))]
|
||||
[(hash-eqv? p)
|
||||
(for/hasheqv ([(k v) (in-hash p)])
|
||||
(values k (walk v)))]
|
||||
[else
|
||||
(for/hash ([(k v) (in-hash p)])
|
||||
(values k (walk v)))])]
|
||||
[_ p])))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
(define (decode-wrap encoded-wrap ht)
|
||||
(hash-ref! ht
|
||||
encoded-wrap
|
||||
(lambda ()
|
||||
(match encoded-wrap
|
||||
[(vector shifts simple-scopes multi-scopes)
|
||||
(make-wrap (decode-map decode-shift shifts ht)
|
||||
(decode-map decode-scope simple-scopes ht)
|
||||
(decode-map decode-shifted-multi-scope multi-scopes ht))]
|
||||
[_ (error 'decode-wrap "bad wrap")]))))
|
||||
|
||||
(define (decode-map decode-one l ht)
|
||||
(cond
|
||||
[(null? l) l]
|
||||
[(not (pair? l))
|
||||
(error 'decode-wrap "bad list")]
|
||||
[else (hash-ref! ht l
|
||||
(lambda ()
|
||||
(cons (decode-one (car l) ht)
|
||||
(decode-map decode-one (cdr l) ht))))]))
|
||||
|
||||
(define (decode-shift s ht)
|
||||
(hash-ref! ht s
|
||||
(lambda ()
|
||||
(match s
|
||||
[(vector to from)
|
||||
(module-shift to from #f #f)]
|
||||
[(vector to from i-to i-from)
|
||||
(module-shift to from i-to i-from)]
|
||||
[_ (error 'decode-wrap "bad shift")]))))
|
||||
|
||||
(define (decode-scope s ht)
|
||||
(hash-ref ht s
|
||||
(lambda ()
|
||||
(unless (encoded-scope? s)
|
||||
(error 'decode-wrap "bad scope: ~e" s))
|
||||
(define v (encoded-scope-content s))
|
||||
(define kind
|
||||
(match v
|
||||
[(? number?) v]
|
||||
[(cons (? number?) _)
|
||||
(car v)]
|
||||
[else (error 'decode-wrap "bad scope")]))
|
||||
(define sc (scope (hash-count ht)
|
||||
(case kind
|
||||
[(0 1) 'module]
|
||||
[(2) 'macro]
|
||||
[(3) 'local]
|
||||
[(4) 'intdef]
|
||||
[else 'use-site])
|
||||
null
|
||||
null
|
||||
#f))
|
||||
(hash-set! ht s sc)
|
||||
(unless (number? v)
|
||||
(define-values (bulk-bindings end)
|
||||
(let loop ([l (cdr v)] [bulk-bindings null])
|
||||
(cond
|
||||
[(pair? l)
|
||||
(loop (cdr l) (cons (list (decode-scope-set (caar l) ht)
|
||||
(decode-bulk-import (cdar l) ht))
|
||||
bulk-bindings))]
|
||||
[else (values (reverse bulk-bindings) l)])))
|
||||
(set-scope-bulk-bindings! sc bulk-bindings)
|
||||
(unless (and (vector? end)
|
||||
(even? (vector-length end)))
|
||||
(error 'decode-wrap "bad scope"))
|
||||
(define bindings
|
||||
(let loop ([i 0])
|
||||
(cond
|
||||
[(= i (vector-length end)) null]
|
||||
[else
|
||||
(append (for/list ([p (in-list (vector-ref end (add1 i)))])
|
||||
(list (vector-ref end i)
|
||||
(decode-scope-set (car p) ht)
|
||||
(decode-binding (cdr p) ht)))
|
||||
(loop (+ i 2)))])))
|
||||
(set-scope-bindings! sc bindings))
|
||||
sc)))
|
||||
|
||||
(define (decode-scope-set l ht)
|
||||
(decode-map decode-scope l ht))
|
||||
|
||||
(define (decode-binding b ht)
|
||||
(hash-ref! ht b
|
||||
(lambda ()
|
||||
(match b
|
||||
[(box (cons base-b (cons sym wraps)))
|
||||
(free-id=?-binding
|
||||
(decode-binding base-b ht)
|
||||
(stx-obj sym wraps 'clean))]
|
||||
[(? symbol?)
|
||||
(local-binding b)]
|
||||
[else
|
||||
;; Leave it encoded, so that the compactness (or not)
|
||||
;; of the encoding is visible; clients decode further
|
||||
;; with `decode-module-binding`
|
||||
(module-binding b)]))))
|
||||
|
||||
(define (decode-module-binding b name)
|
||||
(define-values (insp-desc rest-b)
|
||||
(match b
|
||||
[(cons (? symbol?) _)
|
||||
(values (car b) (cdr b))]
|
||||
[else
|
||||
(values #f b)]))
|
||||
(define (decode-nominal-modidx-plus-phase n mod-phase)
|
||||
(match n
|
||||
[(? module-path-index?)
|
||||
(values n mod-phase 0)]
|
||||
[(cons nom-modix (cons import-phase nom-phase))
|
||||
(values nom-modix nom-phase import-phase)]
|
||||
[(cons nom-modix import-phase)
|
||||
(values nom-modix mod-phase import-phase)]
|
||||
[_
|
||||
(error 'decode-module-binding "bad encoding")]))
|
||||
(match rest-b
|
||||
[(and modidx (? module-path-index?))
|
||||
(decoded-module-binding modidx name 0
|
||||
modidx name 0
|
||||
0 insp-desc)]
|
||||
[(cons (and modidx (? module-path-index?))
|
||||
(and name (? symbol?)))
|
||||
(decoded-module-binding modidx name 0
|
||||
modidx name 0
|
||||
0 insp-desc)]
|
||||
[(cons (and modidx (? module-path-index?))
|
||||
(and nom-modidx (? module-path-index?)))
|
||||
(decoded-module-binding modidx name 0
|
||||
nom-modidx name 0
|
||||
0 insp-desc)]
|
||||
[(list* modidx (and name (? symbol?))
|
||||
nominal-modidx-plus-phase nom-name)
|
||||
(define-values (nom-modidx nom-phase import-phase)
|
||||
(decode-nominal-modidx-plus-phase nominal-modidx-plus-phase 0))
|
||||
(decoded-module-binding modidx name 0
|
||||
nom-modidx nom-name nom-phase
|
||||
import-phase insp-desc)]
|
||||
[(list* modidx mod-phase (and name (? symbol?))
|
||||
nominal-modidx-plus-phase nom-name)
|
||||
(define-values (nom-modidx nom-phase import-phase)
|
||||
(decode-nominal-modidx-plus-phase nominal-modidx-plus-phase mod-phase))
|
||||
(decoded-module-binding modidx name mod-phase
|
||||
nom-modidx nom-name nom-phase
|
||||
import-phase insp-desc)]
|
||||
[_ (error 'decode-module-binding "bad encoding")]))
|
||||
|
||||
(define (decode-bulk-import l ht)
|
||||
(hash-ref! ht l
|
||||
(lambda ()
|
||||
(match l
|
||||
[(vector (and modidx (? module-path-index?))
|
||||
src-phase
|
||||
info
|
||||
(and insp-desc (or #f (? symbol?))))
|
||||
(define-values (phase prefix excepts)
|
||||
(match info
|
||||
[(or #f (? exact-integer?))
|
||||
(values info #f '#())]
|
||||
[(cons phase (and prefix (? symbol?)))
|
||||
(values phase prefix '#())]
|
||||
[(cons phase (cons excepts prefix))
|
||||
(values phase prefix excepts)]
|
||||
[(cons phase excepts)
|
||||
(values phase #f excepts)]
|
||||
[_ (error 'decode-wrap "bad bulk import info")]))
|
||||
(all-from-module modidx
|
||||
phase
|
||||
src-phase
|
||||
insp-desc
|
||||
(if excepts
|
||||
(vector->list excepts)
|
||||
null)
|
||||
prefix)]
|
||||
[_ (error 'decode-wrap "bad bulk import")]))))
|
||||
|
||||
(define (decode-shifted-multi-scope sms ht)
|
||||
(unless (pair? sms)
|
||||
(error 'decode-wrap "bad multi-scope pair"))
|
||||
(list (decode-multi-scope (car sms) ht)
|
||||
(cdr sms)))
|
||||
|
||||
(define (decode-multi-scope ms ht)
|
||||
(unless (and (vector? ms)
|
||||
(odd? (vector-length ms)))
|
||||
(error 'decode-wrap "bad multi scope"))
|
||||
(hash-ref ht ms
|
||||
(lambda ()
|
||||
(define multi (multi-scope (hash-count ht)
|
||||
(vector-ref ms (sub1 (vector-length ms)))
|
||||
null))
|
||||
(hash-set! ht ms multi)
|
||||
(define scopes
|
||||
(let loop ([i 0])
|
||||
(cond
|
||||
[(= (add1 i) (vector-length ms)) null]
|
||||
[else
|
||||
(define s (decode-scope (vector-ref ms (add1 i)) ht))
|
||||
(when (scope-multi-owner s)
|
||||
(error 'decode-wrap "bad scope owner: ~e while reading ~e"
|
||||
(scope-multi-owner s)
|
||||
multi))
|
||||
(set-scope-multi-owner! s multi)
|
||||
(cons (list (vector-ref ms i)
|
||||
s)
|
||||
(loop (+ i 2)))])))
|
||||
(set-multi-scope-scopes! multi scopes)
|
||||
multi)))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
||||
|
|
|
|||
|
|
@ -20,12 +20,12 @@
|
|||
;; ----------------------------------------
|
||||
;; Structures to represent bytecode
|
||||
|
||||
(define-syntax-rule (define-form-struct* id id+par ([field-id field-contract] ...))
|
||||
(define-syntax-rule (define-form-struct* id id+par ([field-id field-contract . options] ...))
|
||||
(begin
|
||||
(define-struct id+par (field-id ...) #:prefab)
|
||||
#;(provide (struct-out id))
|
||||
(provide/contract
|
||||
[struct id ([field-id field-contract] ...)])))
|
||||
(define-struct id+par ([field-id . options] ...) #:prefab)
|
||||
(provide
|
||||
(contract-out
|
||||
[struct id ([field-id field-contract] ...)]))))
|
||||
|
||||
(define-struct zo () #:prefab)
|
||||
(provide (struct-out zo))
|
||||
|
|
@ -58,30 +58,9 @@
|
|||
function-shape?
|
||||
struct-shape?)]))
|
||||
|
||||
;; Syntax object
|
||||
(define ((alist/c k? v?) l)
|
||||
(let loop ([l l])
|
||||
(match l
|
||||
[(list) #t]
|
||||
[(list* (? k?) (? v?) l)
|
||||
(loop l)]
|
||||
[_ #f])))
|
||||
|
||||
(define mark-map?
|
||||
(alist/c number? module-path-index?)
|
||||
#;(hash/c number? module-path-index?))
|
||||
|
||||
(define-form-struct wrap ())
|
||||
(define-form-struct wrapped ([datum any/c]
|
||||
[wraps any/c]
|
||||
[tamper-status (or/c 'clean 'armed 'tainted)]))
|
||||
|
||||
;; In stxs of prefix:
|
||||
(define-form-struct stx ([encoded wrapped?]))
|
||||
|
||||
(define-form-struct prefix ([num-lifts exact-nonnegative-integer?]
|
||||
[toplevels (listof (or/c #f symbol? global-bucket? module-variable?))]
|
||||
[stxs list?] ; should be (listof stx?) sets up top-level and syntax-object array
|
||||
[stxs (listof (or/c #f stx?))] ; #f is unusual, but it can happen when one is optimized away at the last moment
|
||||
[src-inspector-desc symbol?]))
|
||||
|
||||
(define-form-struct form ())
|
||||
|
|
@ -196,55 +175,52 @@
|
|||
;; Top-level `require'
|
||||
(define-form-struct (req form) ([reqs stx?] [dummy toplevel?]))
|
||||
|
||||
|
||||
;; Syntax objects
|
||||
|
||||
(define-form-struct stx ([content stx-obj?]))
|
||||
|
||||
(define-form-struct stx-obj ([datum any/c] ; S-expression with `wrapped` components
|
||||
[wrap any/c] ; shuold be `wrap?`, but encoded form appears initially
|
||||
[tamper-status (or/c 'clean 'armed 'tainted)]))
|
||||
|
||||
(define-form-struct wrap ([shifts (listof module-shift?)]
|
||||
[simple-scopes (listof scope?)]
|
||||
[multi-scopes (listof (list/c multi-scope? (or/c #f exact-integer?)))]))
|
||||
|
||||
(define-form-struct module-shift ([from (or/c #f module-path-index?)]
|
||||
[to (or/c #f module-path-index?)]
|
||||
[from-inspector-desc (or/c #f symbol?)]
|
||||
[to-inspector-desc (or/c #f symbol?)]))
|
||||
|
||||
(define-form-struct scope ([name (or/c 'root exact-nonnegative-integer?)] ; 'root is special; otherwise, just for printing
|
||||
[kind symbol?]
|
||||
[bindings (listof (list/c symbol? (listof scope?) binding?)) #:mutable]
|
||||
[bulk-bindings (listof (list/c (listof scope?) all-from-module?)) #:mutable]
|
||||
[multi-owner (or/c #f multi-scope?) #:mutable]))
|
||||
(define-form-struct multi-scope ([name exact-nonnegative-integer?]
|
||||
[src-name any/c] ; debugging info, such as module name
|
||||
[scopes (listof (list/c (or/c #f exact-integer?) scope?)) #:mutable]))
|
||||
|
||||
(define-form-struct binding ())
|
||||
(define-form-struct (free-id=?-binding binding) ([base (and/c binding?
|
||||
(not/c free-id=?-binding?))]
|
||||
[id stx-obj?]))
|
||||
(define-form-struct (local-binding binding) ([name symbol?]))
|
||||
(define-form-struct (module-binding binding) ([encoded any/c]))
|
||||
;; Convert `module-binding` to `decoded-module-binding` with `decode-module-binding`:
|
||||
(define-form-struct (decoded-module-binding binding) ([path (or/c #f module-path-index?)]
|
||||
[name symbol?]
|
||||
[phase exact-integer?]
|
||||
[nominal-path (or/c #f module-path-index?)]
|
||||
[nominal-export-name symbol?]
|
||||
[nominal-phase (or/c #f exact-integer?)]
|
||||
[import-phase (or/c #f exact-integer?)]
|
||||
[inspector-desc (or/c #f symbol?)]))
|
||||
|
||||
(define-form-struct all-from-module ([path module-path-index?]
|
||||
[phase (or/c exact-integer? #f)]
|
||||
[src-phase (or/c exact-integer? #f)]
|
||||
[inspector-desc symbol?]
|
||||
[exceptions (listof symbol?)]
|
||||
[prefix (or/c symbol? #f)]
|
||||
[context (or/c (listof exact-integer?)
|
||||
(vector/c (listof exact-integer?) any/c))]))
|
||||
|
||||
(define-form-struct nominal-path ())
|
||||
(define-form-struct (simple-nominal-path nominal-path) ([value module-path-index?]))
|
||||
(define-form-struct (imported-nominal-path nominal-path) ([value module-path-index?]
|
||||
[import-phase exact-integer?]))
|
||||
(define-form-struct (phased-nominal-path nominal-path) ([value module-path-index?]
|
||||
[import-phase (or/c false/c exact-integer?)]
|
||||
[phase exact-integer?]))
|
||||
|
||||
(define-form-struct module-binding ())
|
||||
(define-form-struct (phased-module-binding module-binding) ([path module-path-index?]
|
||||
[phase exact-integer?]
|
||||
[export-name any/c]
|
||||
[nominal-path nominal-path?]
|
||||
[nominal-export-name any/c]))
|
||||
(define-form-struct (exported-nominal-module-binding module-binding) ([path module-path-index?]
|
||||
[export-name any/c]
|
||||
[nominal-path nominal-path?]
|
||||
[nominal-export-name any/c]))
|
||||
(define-form-struct (nominal-module-binding module-binding) ([path module-path-index?]
|
||||
[nominal-path nominal-path?]))
|
||||
(define-form-struct (exported-module-binding module-binding) ([path module-path-index?]
|
||||
[export-name any/c]))
|
||||
(define-form-struct (simple-module-binding module-binding) ([path module-path-index?]))
|
||||
|
||||
(define-form-struct (module-rename wrap) ([phase (or/c exact-integer? #f)]
|
||||
[kind (or/c 'marked 'normal)]
|
||||
[set-id any/c]
|
||||
[unmarshals (listof all-from-module?)]
|
||||
[renames (listof (cons/c symbol? module-binding?))]
|
||||
[mark-renames any/c]
|
||||
[plus-kern? boolean?]))
|
||||
|
||||
; XXX better name for 'flag'
|
||||
(define-form-struct (top-level-rename wrap) ([flag boolean?]))
|
||||
|
||||
; XXX better name for 'value'
|
||||
(define-form-struct (mark-barrier wrap) ([value symbol?]))
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
|
||||
[prefix (or/c symbol? #f)]))
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user