Added new primitive: symbol-unreadable?
Updated Scheme implementation of zo parsing and marshaling
- Separated the structs into a different file and added contracts
- Implemented stxobj marshalling
- Fixed many small bugs in parser and marshaller
- Added new structs for new parser cases
Done by Blake Johnson (BYU)
Committed by Jay
svn: r18130
original commit: a8d00cc3b3
This commit is contained in:
Jay McCarthy
commit
21a504a86c
|
|
@ -1,17 +1,30 @@
|
|||
#lang scheme/base
|
||||
(require compiler/zo-parse
|
||||
scheme/match)
|
||||
(require compiler/zo-structs
|
||||
scheme/match
|
||||
scheme/list
|
||||
scheme/dict)
|
||||
|
||||
(provide zo-marshal)
|
||||
|
||||
#| Unresolved Issues
|
||||
|
||||
Less sharing occurs than in the C implementation, creating much larger files
|
||||
|
||||
encode-all-from-module only handles one case
|
||||
|
||||
What is the purpose of protect-quote? It was making it so certain things (like paths) weren't being encoded correctly.
|
||||
|
||||
|#
|
||||
|
||||
;; Doesn't write as compactly as MzScheme, since list and pair sequences
|
||||
;; are not compacted, and symbols are not written in short form
|
||||
|
||||
(define current-wrapped-ht (make-parameter #f))
|
||||
(define (zo-marshal top)
|
||||
(match top
|
||||
[(struct compilation-top (max-let-depth prefix form))
|
||||
(let ([encountered (make-hasheq)]
|
||||
[shared (make-hasheq)])
|
||||
[shared (make-hasheq)]
|
||||
[wrapped (make-hasheq)])
|
||||
(let ([visit (lambda (v)
|
||||
(if (hash-ref shared v #f)
|
||||
#f
|
||||
|
|
@ -24,10 +37,11 @@
|
|||
(when (closure? v)
|
||||
(hash-set! shared v (add1 (hash-count shared))))
|
||||
#t))))])
|
||||
(parameterize ([current-wrapped-ht wrapped])
|
||||
(traverse-prefix prefix visit)
|
||||
(traverse-form form visit))
|
||||
(traverse-form form visit)))
|
||||
(let* ([s (open-output-bytes)]
|
||||
[out (make-out s (lambda (v) (hash-ref shared v #f)))]
|
||||
[out (make-out s (lambda (v) (hash-ref shared v #f)) wrapped)]
|
||||
[offsets
|
||||
(map (lambda (v)
|
||||
(let ([v (cdr v)])
|
||||
|
|
@ -41,17 +55,19 @@
|
|||
(begin
|
||||
(set! skip? #f)
|
||||
#f)
|
||||
(hash-ref shared v2 #f)))))))))
|
||||
(hash-ref shared v2 #f))))
|
||||
wrapped)))))
|
||||
(sort (hash-map shared (lambda (k v) (cons v k)))
|
||||
<
|
||||
#:key car))]
|
||||
[post-shared (file-position s)]
|
||||
[all-short? (post-shared . < . #xFFFF)])
|
||||
(out-data (list* max-let-depth prefix (protect-quote form)) out)
|
||||
(let ([res (get-output-bytes s)])
|
||||
(let ([res (get-output-bytes s)]
|
||||
[version-bs (string->bytes/latin-1 (version))])
|
||||
(bytes-append #"#~"
|
||||
(bytes (string-length (version)))
|
||||
(string->bytes/latin-1 (version))
|
||||
(bytes (bytes-length version-bs))
|
||||
version-bs
|
||||
(int->bytes (add1 (hash-count shared)))
|
||||
(bytes (if all-short?
|
||||
1
|
||||
|
|
@ -103,8 +119,14 @@
|
|||
(traverse-data modidx visit)))
|
||||
(traverse-data sym visit)]))
|
||||
|
||||
(define (traverse-stx tl visit)
|
||||
(error "cannot handle syntax objects, yet"))
|
||||
(define (traverse-wrapped w visit)
|
||||
(define ew (hash-ref! (current-wrapped-ht) w (lambda () (encode-wrapped w))))
|
||||
(traverse-data ew visit))
|
||||
|
||||
(define (traverse-stx s visit)
|
||||
(when s
|
||||
(traverse-wrapped (stx-encoded s) visit)))
|
||||
|
||||
|
||||
(define (traverse-form form visit)
|
||||
(match form
|
||||
|
|
@ -166,7 +188,7 @@
|
|||
(traverse-expr proc visit)
|
||||
(traverse-expr args-expr visit)]
|
||||
[(struct seq (exprs))
|
||||
(for-each (lambda (expr) (traverse-expr expr visit)) exprs)]
|
||||
(for-each (lambda (expr) (traverse-form expr visit)) exprs)]
|
||||
[(struct beg0 (exprs))
|
||||
(for-each (lambda (expr) (traverse-expr expr visit)) exprs)]
|
||||
[(struct with-cont-mark (key val body))
|
||||
|
|
@ -195,7 +217,17 @@
|
|||
[(pair? expr)
|
||||
(traverse-data (car expr) visit)
|
||||
(traverse-data (cdr expr) visit)]
|
||||
[else (void)]))
|
||||
[(vector? expr)
|
||||
(for ([e (in-vector expr)])
|
||||
(traverse-data e visit))]
|
||||
[(box? expr)
|
||||
(traverse-data (unbox expr) visit)]
|
||||
[(stx? expr)
|
||||
(traverse-stx expr visit)]
|
||||
[(wrapped? expr)
|
||||
(traverse-wrapped expr visit)]
|
||||
[else
|
||||
(void)]))
|
||||
|
||||
(define (traverse-lam expr visit)
|
||||
(match expr
|
||||
|
|
@ -313,8 +345,7 @@
|
|||
(define-struct case-seq (name lams))
|
||||
(define-struct (seq0 seq) ())
|
||||
|
||||
(define-struct out (s shared-index))
|
||||
|
||||
(define-struct out (s shared-index encoded-wraps))
|
||||
(define (out-shared v out k)
|
||||
(let ([v ((out-shared-index out) v)])
|
||||
(if v
|
||||
|
|
@ -322,6 +353,10 @@
|
|||
(out-byte CPT_SYMREF out)
|
||||
(out-number v out))
|
||||
(k))))
|
||||
(define (display-byte b)
|
||||
(if (b . <= . #xf)
|
||||
(printf "0~x" b)
|
||||
(printf "~x" b)))
|
||||
|
||||
(define (out-byte v out)
|
||||
(write-byte v (out-s out)))
|
||||
|
|
@ -343,7 +378,7 @@
|
|||
(out-byte (bitwise-ior #x80 (bitwise-and n #x3F)) out)
|
||||
(out-byte (bitwise-and #xFF (arithmetic-shift n -6)) out)]
|
||||
[else
|
||||
(out-bytes #xF0 out)
|
||||
(out-byte #xF0 out)
|
||||
(out-bytes (int->bytes n) out)]))
|
||||
|
||||
(define (out-syntax key val out)
|
||||
|
|
@ -401,7 +436,13 @@
|
|||
(if (andmap (lambda (x) (equal? x default)) l)
|
||||
#f
|
||||
(list->vector l)))]
|
||||
[l (map cdr other-requires)]
|
||||
[l
|
||||
(let loop ([l other-requires])
|
||||
(match l
|
||||
[(list)
|
||||
empty]
|
||||
[(list-rest (cons phase reqs) rst)
|
||||
(list* phase reqs (loop rst))]))]
|
||||
[l (cons (length other-requires) l)]
|
||||
[l (cons (lookup-req #f) l)] ; dt-requires
|
||||
[l (cons (lookup-req -1) l)] ; tt-requires
|
||||
|
|
@ -460,17 +501,97 @@
|
|||
out
|
||||
(lambda ()
|
||||
(out-byte CPT_MODULE_VAR out)
|
||||
(let-values ([(p b) (module-path-index-split modidx)])
|
||||
(if (symbol? p)
|
||||
(out-data p out)
|
||||
(out-data modidx out)))
|
||||
(out-data modidx out)
|
||||
(out-data sym out)
|
||||
(unless (zero? phase)
|
||||
(out-number -2 out))
|
||||
(out-number pos out)))]))
|
||||
|
||||
(define (out-stx tl out)
|
||||
(error "cannot handle syntax objects, yet"))
|
||||
(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 all)
|
||||
(match all
|
||||
[(struct all-from-module (path phase src-phase exceptions prefix))
|
||||
(list* path phase src-phase)]))
|
||||
|
||||
(define (encode-wraps wraps)
|
||||
(for/list ([wrap (in-list wraps)])
|
||||
(match wrap
|
||||
[(struct phase-shift (amt src dest))
|
||||
(box (vector amt src dest #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))
|
||||
(define encoded-renames (encode-module-bindings renames))
|
||||
(define-values (maybe-unmarshals maybe-renames) (if (null? encoded-unmarshals)
|
||||
(values encoded-renames mark-renames)
|
||||
(values encoded-unmarshals (cons encoded-renames mark-renames))))
|
||||
(define mod-rename (list* phase encoded-kind set-id maybe-unmarshals maybe-renames))
|
||||
(if plus-kern?
|
||||
(cons #t mod-rename)
|
||||
mod-rename)]
|
||||
[(struct lexical-rename (bool1 bool2 alist))
|
||||
(define len (length alist))
|
||||
(define vec (make-vector (+ (* 2 len) 2))) ; + 2 for booleans at the beginning
|
||||
(vector-set! vec 0 bool1)
|
||||
(vector-set! vec 1 bool2)
|
||||
(for ([(k v) (in-dict alist)]
|
||||
[i (in-naturals)])
|
||||
(vector-set! vec (+ 2 i) k)
|
||||
(vector-set! vec (+ 2 i len) v))
|
||||
vec]
|
||||
[(struct prune (syms))
|
||||
(box syms)]
|
||||
[(struct wrap-mark (val))
|
||||
(list val)])))
|
||||
|
||||
(define (encode-wrapped w)
|
||||
(match w
|
||||
[(struct wrapped (datum wraps certs))
|
||||
(vector
|
||||
(cons
|
||||
datum
|
||||
(encode-wraps wraps))
|
||||
certs)]))
|
||||
|
||||
(define (lookup-encoded-wrapped w out)
|
||||
(hash-ref (out-encoded-wraps out) w))
|
||||
|
||||
(define (out-wrapped w out)
|
||||
(out-data (lookup-encoded-wrapped w out) out))
|
||||
|
||||
(define (out-stx s out)
|
||||
(out-shared s out
|
||||
(lambda ()
|
||||
(match s
|
||||
[(struct stx (encoded))
|
||||
(out-byte CPT_STX out)
|
||||
(out-wrapped encoded out)]))))
|
||||
|
||||
(define (out-form form out)
|
||||
(match form
|
||||
|
|
@ -704,10 +825,12 @@
|
|||
l)
|
||||
out))]))
|
||||
|
||||
(define (out-as-bytes expr ->bytes CPT len2 out)
|
||||
(define (out-as-bytes expr ->bytes CPT len2 out #:before-length [before-length #f])
|
||||
(out-shared expr out (lambda ()
|
||||
(let ([s (->bytes expr)])
|
||||
(out-byte CPT out)
|
||||
(when before-length
|
||||
(out-number before-length out))
|
||||
(out-number (bytes-length s) out)
|
||||
(when len2 (out-number len2 out))
|
||||
(out-bytes s out)))))
|
||||
|
|
@ -721,6 +844,13 @@
|
|||
|
||||
(define (out-value expr out)
|
||||
(cond
|
||||
[(and (symbol? expr) (not (symbol-interned? expr)))
|
||||
(out-as-bytes expr
|
||||
#:before-length (if (symbol-unreadable? expr) 0 1)
|
||||
(compose string->bytes/utf-8 symbol->string)
|
||||
CPT_WEIRD_SYMBOL
|
||||
#f
|
||||
out)]
|
||||
[(symbol? expr)
|
||||
(out-as-bytes expr
|
||||
(compose string->bytes/utf-8 symbol->string)
|
||||
|
|
@ -784,7 +914,9 @@
|
|||
(out-number (cond
|
||||
[(hash-eqv? expr) 2]
|
||||
[(hash-eq? expr) 0]
|
||||
[else 1]))
|
||||
[else 1])
|
||||
out)
|
||||
(out-number (hash-count expr) out)
|
||||
(for ([(k v) (in-hash expr)])
|
||||
(out-data k out)
|
||||
(out-data v out))]
|
||||
|
|
@ -805,21 +937,31 @@
|
|||
(out-marshaled module-type-num
|
||||
(module-decl-content expr)
|
||||
out)]
|
||||
[(stx? expr)
|
||||
(out-stx expr out)]
|
||||
[(wrapped? expr)
|
||||
(out-wrapped expr out)]
|
||||
[else
|
||||
(out-byte CPT_QUOTE out)
|
||||
(let ([s (open-output-bytes)])
|
||||
(write (if (quoted? expr) (quoted-v expr) expr) s)
|
||||
(write (if (quoted? expr)
|
||||
(quoted-v expr)
|
||||
expr) s)
|
||||
(out-byte CPT_ESCAPE out)
|
||||
(let ([bstr (get-output-bytes s)])
|
||||
(out-number (bytes-length bstr) out)
|
||||
(out-bytes bstr out)))]))
|
||||
|
||||
(define-struct quoted (v))
|
||||
|
||||
(define-struct quoted (v) #:prefab)
|
||||
|
||||
(define (protect-quote v)
|
||||
(if (or (list? v) (vector? v) (box? v) (hash? v))
|
||||
v
|
||||
#;(if (or (list? v) (vector? v) (box? v) (hash? v))
|
||||
(make-quoted v)
|
||||
v))
|
||||
|
||||
|
||||
(define-struct svector (vec))
|
||||
|
||||
;; ----------------------------------------
|
||||
|
|
|
|||
|
|
@ -1,83 +1,33 @@
|
|||
#lang scheme/base
|
||||
(require mzlib/etc
|
||||
scheme/match
|
||||
scheme/list)
|
||||
scheme/list
|
||||
compiler/zo-structs)
|
||||
|
||||
(provide zo-parse)
|
||||
(provide (all-from-out compiler/zo-structs))
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Structures to represent bytecode
|
||||
#| Unresolved Issues
|
||||
|
||||
(define-syntax-rule (define-form-struct* id id+par (field-id ...))
|
||||
(begin
|
||||
(define-struct id+par (field-id ...) #:transparent)
|
||||
(provide (struct-out id))))
|
||||
The order of indirect-et-provides, indirect-syntax-provides, indirect-provides was changed, is that okay?
|
||||
|
||||
(define-syntax define-form-struct
|
||||
(syntax-rules ()
|
||||
[(_ (id sup) . rest)
|
||||
(define-form-struct* id (id sup) . rest)]
|
||||
[(_ id . rest)
|
||||
(define-form-struct* id id . rest)]))
|
||||
orig-port of cport struct is never used, is it needed?
|
||||
|
||||
(define-form-struct compilation-top (max-let-depth prefix code)) ; compiled code always wrapped with this
|
||||
Lines 628, 630 seem to be only for debugging and should probably throw errors
|
||||
|
||||
(define-form-struct prefix (num-lifts toplevels stxs)) ; sets up top-level and syntax-object array
|
||||
unmarshal-stx-get also seems to be for debugging and should probably throw an error
|
||||
|
||||
;; In toplevels of resove prefix:
|
||||
(define-form-struct global-bucket (name)) ; top-level binding
|
||||
(define-form-struct module-variable (modidx sym pos phase)) ; direct access to exported id
|
||||
vector and pair cases of decode-wraps seem to do different things from the corresponding C code
|
||||
|
||||
;; In stxs of prefix:
|
||||
(define-form-struct stx (encoded))
|
||||
Line 816: This should be an eqv placeholder (but they don't exist)
|
||||
|
||||
(define-form-struct form ())
|
||||
(define-form-struct (expr form) ())
|
||||
Line 634: Export registry is always matched as false, but might not be
|
||||
|
||||
(define-form-struct (mod form) (name self-modidx prefix provides requires body syntax-body unexported
|
||||
max-let-depth dummy lang-info internal-context))
|
||||
What are the real differences between the module-binding cases?
|
||||
|
||||
(define-form-struct (lam expr) (name flags num-params param-types rest? closure-map closure-types max-let-depth body)) ; `lambda'
|
||||
(define-form-struct (closure expr) (code gen-id)) ; a static closure (nothing to close over)
|
||||
(define-form-struct (case-lam expr) (name clauses)) ; each clause is an lam
|
||||
|
||||
(define-form-struct (let-one expr) (rhs body flonum?)) ; pushes one value onto stack
|
||||
(define-form-struct (let-void expr) (count boxes? body)) ; create new stack slots
|
||||
(define-form-struct (install-value expr) (count pos boxes? rhs body)) ; set existing stack slot(s)
|
||||
(define-form-struct (let-rec expr) (procs body)) ; put `letrec'-bound closures into existing stack slots
|
||||
(define-form-struct (boxenv expr) (pos body)) ; box existing stack element
|
||||
|
||||
(define-form-struct (localref expr) (unbox? pos clear? other-clears? flonum?)) ; access local via stack
|
||||
|
||||
(define-form-struct (toplevel expr) (depth pos const? ready?)) ; access binding via prefix array (which is on stack)
|
||||
(define-form-struct (topsyntax expr) (depth pos midpt)) ; access syntax object via prefix array (which is on stack)
|
||||
|
||||
(define-form-struct (application expr) (rator rands)) ; function call
|
||||
(define-form-struct (branch expr) (test then else)) ; `if'
|
||||
(define-form-struct (with-cont-mark expr) (key val body)) ; `with-continuation-mark'
|
||||
(define-form-struct (beg0 expr) (seq)) ; `begin0'
|
||||
(define-form-struct (seq form) (forms)) ; `begin'
|
||||
(define-form-struct (splice form) (forms)) ; top-level `begin'
|
||||
(define-form-struct (varref expr) (toplevel)) ; `#%variable-reference'
|
||||
(define-form-struct (assign expr) (id rhs undef-ok?)) ; top-level or module-level set!
|
||||
(define-form-struct (apply-values expr) (proc args-expr)) ; `(call-with-values (lambda () ,args-expr) ,proc)
|
||||
(define-form-struct (primval expr) (id)) ; direct preference to a kernel primitive
|
||||
|
||||
;; Definitions (top level or within module):
|
||||
(define-form-struct (def-values form) (ids rhs))
|
||||
(define-form-struct (def-syntaxes form) (ids rhs prefix max-let-depth))
|
||||
(define-form-struct (def-for-syntax form) (ids rhs prefix max-let-depth))
|
||||
|
||||
;; Top-level `require'
|
||||
(define-form-struct (req form) (reqs dummy))
|
||||
|
||||
;; A static closure can refer directly to itself, creating a cycle
|
||||
(define-struct indirect ([v #:mutable]) #:prefab)
|
||||
(provide (struct-out indirect))
|
||||
|
||||
;; A provided identifier
|
||||
(define-form-struct provided (name src src-name nom-src src-phase protected? insp))
|
||||
I think parse-module-path-index was only used for debugging, so it is short-circuited now
|
||||
|
||||
|#
|
||||
;; ----------------------------------------
|
||||
;; Bytecode unmarshalers for various forms
|
||||
|
||||
|
|
@ -236,14 +186,24 @@
|
|||
(define (read-splice v)
|
||||
(make-splice (seq-forms v)))
|
||||
|
||||
(define (in-list* l n)
|
||||
(make-do-sequence
|
||||
(lambda ()
|
||||
(values (lambda (l) (apply values (take l n)))
|
||||
(lambda (l) (drop l n))
|
||||
l
|
||||
(lambda (l) (>= (length l) n))
|
||||
(lambda _ #t)
|
||||
(lambda _ #t)))))
|
||||
|
||||
(define (read-module v)
|
||||
(match v
|
||||
[`(,name ,self-modidx ,lang-info ,functional? ,et-functional?
|
||||
,rename ,max-let-depth ,dummy
|
||||
,prefix
|
||||
,indirect-provides ,num-indirect-provides
|
||||
,indirect-syntax-provides ,num-indirect-syntax-provides
|
||||
,indirect-et-provides ,num-indirect-et-provides
|
||||
,indirect-syntax-provides ,num-indirect-syntax-provides
|
||||
,indirect-provides ,num-indirect-provides
|
||||
,protects ,et-protects
|
||||
,provide-phase-count . ,rest)
|
||||
(let ([phase-data (take rest (* 9 provide-phase-count))])
|
||||
|
|
@ -288,15 +248,18 @@
|
|||
(cons 1 syntax-requires)
|
||||
(cons -1 template-requires)
|
||||
(cons #f label-requires)
|
||||
more-requires)
|
||||
(for/list ([(phase reqs) (in-list* more-requires 2)])
|
||||
(cons phase reqs)))
|
||||
(vector->list body)
|
||||
(map (lambda (sb)
|
||||
(match sb
|
||||
[(? def-syntaxes?) sb]
|
||||
[(? def-for-syntax?) sb]
|
||||
[`#(,ids ,expr ,max-let-depth ,prefix ,for-stx?)
|
||||
((if for-stx?
|
||||
make-def-for-syntax
|
||||
make-def-syntaxes)
|
||||
ids expr prefix max-let-depth)]))
|
||||
(if (list? ids) ids (list ids)) expr prefix max-let-depth)]))
|
||||
(vector->list syntax-body))
|
||||
(list (vector->list indirect-provides)
|
||||
(vector->list indirect-syntax-provides)
|
||||
|
|
@ -387,10 +350,13 @@
|
|||
(loop (subbytes so n))))))
|
||||
|
||||
(define (read-simple-number p)
|
||||
;; 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 mpis))
|
||||
|
||||
(define-struct cport ([pos #:mutable] shared-start orig-port size bytes symtab shared-offsets decoded rns mpis))
|
||||
|
||||
(define (cport-rpos cp)
|
||||
(+ (cport-pos cp) (cport-shared-start cp)))
|
||||
|
||||
(define (cp-getc cp)
|
||||
(begin-with-definitions
|
||||
|
|
@ -516,18 +482,7 @@
|
|||
(define-struct not-ready ())
|
||||
|
||||
;; ----------------------------------------
|
||||
;; Synatx unmarshaling
|
||||
|
||||
(define-form-struct wrapped (datum wraps certs))
|
||||
|
||||
(define-form-struct wrap ())
|
||||
(define-form-struct (lexical-rename wrap) (alist))
|
||||
(define-form-struct (phase-shift wrap) (amt src dest))
|
||||
(define-form-struct (prune wrap) (sym))
|
||||
(define-form-struct (module-rename wrap) (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))
|
||||
;; Syntax unmarshaling
|
||||
|
||||
(define (decode-stx cp v)
|
||||
(if (integer? v)
|
||||
|
|
@ -591,7 +546,10 @@
|
|||
(map loop (cdr (vector->list (struct->vector v)))))))]
|
||||
[else (add-wrap v)]))))))
|
||||
|
||||
|
||||
|
||||
(define (decode-wraps cp w)
|
||||
; A wraps is either a indirect reference or a list of wrap-elems (from stxobj.c:252)
|
||||
(if (integer? w)
|
||||
(let-values ([(w2 decoded?) (unmarshal-stx-get cp w)])
|
||||
(if decoded?
|
||||
|
|
@ -601,7 +559,9 @@
|
|||
w2)))
|
||||
(map (lambda (a)
|
||||
(let aloop ([a a])
|
||||
; A wrap-elem is either
|
||||
(cond
|
||||
; A reference
|
||||
[(integer? a)
|
||||
(let-values ([(a2 decoded?) (unmarshal-stx-get cp a)])
|
||||
(if decoded?
|
||||
|
|
@ -609,11 +569,12 @@
|
|||
(let ([a2 (aloop a2)])
|
||||
(unmarshal-stx-set! cp a a2)
|
||||
a2)))]
|
||||
; A mark (not actually a number as the C says, but a (list <num>)
|
||||
[(and (pair? a) (null? (cdr a)) (number? (car a)))
|
||||
;; a mark
|
||||
(string->symbol (format "mark~a" (car a)))]
|
||||
(make-wrap-mark (car a))]
|
||||
|
||||
[(vector? a)
|
||||
(make-lexical-rename
|
||||
(make-lexical-rename (vector-ref a 0) (vector-ref a 1)
|
||||
(let ([top (+ (/ (- (vector-length a) 2) 2) 2)])
|
||||
(let loop ([i 2])
|
||||
(if (= i top)
|
||||
|
|
@ -636,7 +597,7 @@
|
|||
(make-module-rename phase
|
||||
(if kind 'marked 'normal)
|
||||
set-id
|
||||
(map (lambda (u)
|
||||
(let ([results (map (lambda (u)
|
||||
(let ([just-phase? (let ([v (cddr u)])
|
||||
(or (number? v) (not v)))])
|
||||
(let-values ([(exns prefix)
|
||||
|
|
@ -655,52 +616,11 @@
|
|||
(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)))))
|
||||
unmarshals)])
|
||||
#;(printf "~nunmarshals: ~S~n" unmarshals)
|
||||
#;(printf "~nunmarshal results: ~S~n" results)
|
||||
results)
|
||||
(decode-renames renames)
|
||||
mark-renames
|
||||
(and plus-kern? 'plus-kern)))]
|
||||
[else (error "bad module rename: ~e" a)]))]
|
||||
|
|
@ -719,6 +639,51 @@
|
|||
[else (error 'decode-wraps "bad wrap element: ~e" a)])))
|
||||
w)))
|
||||
|
||||
(define (in-vector* v n)
|
||||
(make-do-sequence
|
||||
(λ ()
|
||||
(values (λ (i) (vector->values v i (+ i n)))
|
||||
(λ (i) (+ i n))
|
||||
0
|
||||
(λ (i) (>= (vector-length v) (+ i n)))
|
||||
(λ _ #t)
|
||||
(λ _ #t)))))
|
||||
|
||||
(define (decode-renames renames)
|
||||
(define decode-nominal-path
|
||||
(match-lambda
|
||||
[(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 Matthew, I'm ashamed
|
||||
(define (nom_mod_p p)
|
||||
(and (pair? p) (not (pair? (cdr p))) (not (symbol? (cdr p)))))
|
||||
|
||||
(for/list ([(k v) (in-vector* renames 2)])
|
||||
(cons k
|
||||
(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 (unmarshal-stx-get cp pos)
|
||||
(if (pos . >= . (vector-length (cport-symtab cp)))
|
||||
(values `(#%bad-index ,pos) #t)
|
||||
|
|
@ -737,19 +702,7 @@
|
|||
(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)]))
|
||||
|
||||
s)
|
||||
;; ----------------------------------------
|
||||
;; Main parsing loop
|
||||
|
||||
|
|
@ -857,9 +810,10 @@
|
|||
[(hash-table)
|
||||
(let ([eq (read-compact-number cp)]
|
||||
[len (read-compact-number cp)])
|
||||
((if (zero? eq)
|
||||
make-hash-placeholder
|
||||
make-hasheq-placeholder)
|
||||
((case eq
|
||||
[(0) make-hasheq-placeholder]
|
||||
[(1) make-hash-placeholder]
|
||||
[(2) make-hash-placeholder])
|
||||
(for/list ([i (in-range len)])
|
||||
(cons (read-compact cp)
|
||||
(read-compact cp)))))]
|
||||
|
|
@ -921,10 +875,13 @@
|
|||
v))
|
||||
v))]
|
||||
[(weird-symbol)
|
||||
(let ([u (read-compact-number cp)]
|
||||
(let ([uninterned (read-compact-number cp)]
|
||||
[str (read-compact-chars cp (read-compact-number cp))])
|
||||
;; FIXME: no way to construct quasi-interned symbols:
|
||||
(string->uninterned-symbol str))]
|
||||
(if (= 1 uninterned)
|
||||
; uninterned is equivalent to weird in the C implementation
|
||||
(string->uninterned-symbol str)
|
||||
; unreadable is equivalent to parallel in the C implementation
|
||||
(string->unreadable-symbol str)))]
|
||||
[(small-marshalled)
|
||||
(read-marshalled (- ch cpt-start) cp)]
|
||||
[(small-application2)
|
||||
|
|
@ -994,7 +951,7 @@
|
|||
(define size* (read-simple-number port))
|
||||
|
||||
(when (shared-size . >= . size*)
|
||||
(error 'bad-read))
|
||||
(error 'zo-parse "Non-shared data segment start is not after shared data segment (according to offsets)"))
|
||||
|
||||
(define rst (read-bytes size* port))
|
||||
|
||||
|
|
@ -1006,14 +963,14 @@
|
|||
|
||||
(define symtab (make-vector symtabsize (make-not-ready)))
|
||||
|
||||
(define cp (make-cport 0 port size* rst symtab so* (make-vector symtabsize #f) (make-hash) (make-hash)))
|
||||
(define cp (make-cport 0 shared-size 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))
|
||||
(define vv (vector-ref symtab i))
|
||||
(when (not-ready? vv)
|
||||
(set-cport-pos! cp (vector-ref so* (sub1 i)))
|
||||
(let ([v (read-compact cp)])
|
||||
(vector-set! symtab i v))))
|
||||
|
||||
(set-cport-pos! cp shared-size)
|
||||
(read-marshalled 'compilation-top-type cp)))
|
||||
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user