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

Added new primitive: symbol-unreadable?

Browse Source 
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 2010-02-17 21:33:00 +00:00
commit 21a504a86c
2 changed files with 585 additions and 486 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

200
collects/compiler/zo-marshal.ss
View File

@ -1,17 +1,30 @@
#lang scheme/base #lang scheme/base
(require compiler/zo-parse (require compiler/zo-structs
scheme/match) scheme/match
scheme/list
scheme/dict)
(provide zo-marshal) (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 ;; Doesn't write as compactly as MzScheme, since list and pair sequences
;; are not compacted, and symbols are not written in short form ;; are not compacted, and symbols are not written in short form
(define current-wrapped-ht (make-parameter #f))
(define (zo-marshal top) (define (zo-marshal top)
(match top (match top
[(struct compilation-top (max-let-depth prefix form)) [(struct compilation-top (max-let-depth prefix form))
(let ([encountered (make-hasheq)] (let ([encountered (make-hasheq)]
[shared (make-hasheq)]) [shared (make-hasheq)]
[wrapped (make-hasheq)])
(let ([visit (lambda (v) (let ([visit (lambda (v)
(if (hash-ref shared v #f) (if (hash-ref shared v #f)
#f #f
@ -24,10 +37,11 @@
(when (closure? v) (when (closure? v)
(hash-set! shared v (add1 (hash-count shared)))) (hash-set! shared v (add1 (hash-count shared))))
#t))))]) #t))))])
(parameterize ([current-wrapped-ht wrapped])
(traverse-prefix prefix visit) (traverse-prefix prefix visit)
(traverse-form form visit)) (traverse-form form visit)))
(let* ([s (open-output-bytes)] (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 [offsets
(map (lambda (v) (map (lambda (v)
(let ([v (cdr v)]) (let ([v (cdr v)])
@ -41,17 +55,19 @@
(begin (begin
(set! skip? #f) (set! skip? #f)
#f) #f)
(hash-ref shared v2 #f))))))))) (hash-ref shared v2 #f))))
wrapped)))))
(sort (hash-map shared (lambda (k v) (cons v k))) (sort (hash-map shared (lambda (k v) (cons v k)))
< <
#:key car))] #:key car))]
[post-shared (file-position s)] [post-shared (file-position s)]
[all-short? (post-shared . < . #xFFFF)]) [all-short? (post-shared . < . #xFFFF)])
(out-data (list* max-let-depth prefix (protect-quote form)) out) (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-append #"#~"
(bytes (string-length (version))) (bytes (bytes-length version-bs))
(string->bytes/latin-1 (version)) version-bs
(int->bytes (add1 (hash-count shared))) (int->bytes (add1 (hash-count shared)))
(bytes (if all-short? (bytes (if all-short?
1 1
@ -103,8 +119,14 @@
(traverse-data modidx visit))) (traverse-data modidx visit)))
(traverse-data sym visit)])) (traverse-data sym visit)]))
(define (traverse-stx tl visit) (define (traverse-wrapped w visit)
(error "cannot handle syntax objects, yet")) (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) (define (traverse-form form visit)
(match form (match form
@ -166,7 +188,7 @@
(traverse-expr proc visit) (traverse-expr proc visit)
(traverse-expr args-expr visit)] (traverse-expr args-expr visit)]
[(struct seq (exprs)) [(struct seq (exprs))
(for-each (lambda (expr) (traverse-expr expr visit)) exprs)] (for-each (lambda (expr) (traverse-form expr visit)) exprs)]
[(struct beg0 (exprs)) [(struct beg0 (exprs))
(for-each (lambda (expr) (traverse-expr expr visit)) exprs)] (for-each (lambda (expr) (traverse-expr expr visit)) exprs)]
[(struct with-cont-mark (key val body)) [(struct with-cont-mark (key val body))
@ -195,7 +217,17 @@
[(pair? expr) [(pair? expr)
(traverse-data (car expr) visit) (traverse-data (car expr) visit)
(traverse-data (cdr 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) (define (traverse-lam expr visit)
(match expr (match expr
@ -313,8 +345,7 @@
(define-struct case-seq (name lams)) (define-struct case-seq (name lams))
(define-struct (seq0 seq) ()) (define-struct (seq0 seq) ())
(define-struct out (s shared-index)) (define-struct out (s shared-index encoded-wraps))
(define (out-shared v out k) (define (out-shared v out k)
(let ([v ((out-shared-index out) v)]) (let ([v ((out-shared-index out) v)])
(if v (if v
@ -322,6 +353,10 @@
(out-byte CPT_SYMREF out) (out-byte CPT_SYMREF out)
(out-number v out)) (out-number v out))
(k)))) (k))))
(define (display-byte b)
(if (b . <= . #xf)
(printf "0~x" b)
(printf "~x" b)))
(define (out-byte v out) (define (out-byte v out)
(write-byte v (out-s out))) (write-byte v (out-s out)))
@ -343,7 +378,7 @@
(out-byte (bitwise-ior #x80 (bitwise-and n #x3F)) out) (out-byte (bitwise-ior #x80 (bitwise-and n #x3F)) out)
(out-byte (bitwise-and #xFF (arithmetic-shift n -6)) out)] (out-byte (bitwise-and #xFF (arithmetic-shift n -6)) out)]
[else [else
(out-bytes #xF0 out) (out-byte #xF0 out)
(out-bytes (int->bytes n) out)])) (out-bytes (int->bytes n) out)]))
(define (out-syntax key val out) (define (out-syntax key val out)
@ -401,7 +436,13 @@
(if (andmap (lambda (x) (equal? x default)) l) (if (andmap (lambda (x) (equal? x default)) l)
#f #f
(list->vector l)))] (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 (length other-requires) l)]
[l (cons (lookup-req #f) l)] ; dt-requires [l (cons (lookup-req #f) l)] ; dt-requires
[l (cons (lookup-req -1) l)] ; tt-requires [l (cons (lookup-req -1) l)] ; tt-requires
@ -460,17 +501,97 @@
out out
(lambda () (lambda ()
(out-byte CPT_MODULE_VAR out) (out-byte CPT_MODULE_VAR out)
(let-values ([(p b) (module-path-index-split modidx)]) (out-data modidx out)
(if (symbol? p)
(out-data p out)
(out-data modidx out)))
(out-data sym out) (out-data sym out)
(unless (zero? phase) (unless (zero? phase)
(out-number -2 out)) (out-number -2 out))
(out-number pos out)))])) (out-number pos out)))]))
(define (out-stx tl out) (define (encode-module-bindings module-bindings)
(error "cannot handle syntax objects, yet")) (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) (define (out-form form out)
(match form (match form
@ -704,10 +825,12 @@
l) l)
out))])) 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 () (out-shared expr out (lambda ()
(let ([s (->bytes expr)]) (let ([s (->bytes expr)])
(out-byte CPT out) (out-byte CPT out)
(when before-length
(out-number before-length out))
(out-number (bytes-length s) out) (out-number (bytes-length s) out)
(when len2 (out-number len2 out)) (when len2 (out-number len2 out))
(out-bytes s out))))) (out-bytes s out)))))
@ -721,6 +844,13 @@
(define (out-value expr out) (define (out-value expr out)
(cond (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) [(symbol? expr)
(out-as-bytes expr (out-as-bytes expr
(compose string->bytes/utf-8 symbol->string) (compose string->bytes/utf-8 symbol->string)
@ -784,7 +914,9 @@
(out-number (cond (out-number (cond
[(hash-eqv? expr) 2] [(hash-eqv? expr) 2]
[(hash-eq? expr) 0] [(hash-eq? expr) 0]
[else 1])) [else 1])
out)
(out-number (hash-count expr) out)
(for ([(k v) (in-hash expr)]) (for ([(k v) (in-hash expr)])
(out-data k out) (out-data k out)
(out-data v out))] (out-data v out))]
@ -805,21 +937,31 @@
(out-marshaled module-type-num (out-marshaled module-type-num
(module-decl-content expr) (module-decl-content expr)
out)] out)]
[(stx? expr)
(out-stx expr out)]
[(wrapped? expr)
(out-wrapped expr out)]
[else [else
(out-byte CPT_QUOTE out) (out-byte CPT_QUOTE out)
(let ([s (open-output-bytes)]) (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) (out-byte CPT_ESCAPE out)
(let ([bstr (get-output-bytes s)]) (let ([bstr (get-output-bytes s)])
(out-number (bytes-length bstr) out) (out-number (bytes-length bstr) out)
(out-bytes bstr out)))])) (out-bytes bstr out)))]))
(define-struct quoted (v))
(define-struct quoted (v) #:prefab)
(define (protect-quote v) (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) (make-quoted v)
v)) v))
(define-struct svector (vec)) (define-struct svector (vec))
;; ---------------------------------------- ;; ----------------------------------------

267
collects/compiler/zo-parse.ss
View File

@ -1,83 +1,33 @@
#lang scheme/base #lang scheme/base
(require mzlib/etc (require mzlib/etc
scheme/match scheme/match
scheme/list) scheme/list
compiler/zo-structs)
(provide zo-parse) (provide zo-parse)
(provide (all-from-out compiler/zo-structs))
;; ---------------------------------------- #| Unresolved Issues
;; Structures to represent bytecode
(define-syntax-rule (define-form-struct* id id+par (field-id ...)) The order of indirect-et-provides, indirect-syntax-provides, indirect-provides was changed, is that okay?
(begin
(define-struct id+par (field-id ...) #:transparent)
(provide (struct-out id))))
(define-syntax define-form-struct orig-port of cport struct is never used, is it needed?
(syntax-rules ()
[(_ (id sup) . rest)
(define-form-struct* id (id sup) . rest)]
[(_ id . rest)
(define-form-struct* id id . rest)]))
(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: vector and pair cases of decode-wraps seem to do different things from the corresponding C code
(define-form-struct global-bucket (name)) ; top-level binding
(define-form-struct module-variable (modidx sym pos phase)) ; direct access to exported id
;; In stxs of prefix: Line 816: This should be an eqv placeholder (but they don't exist)
(define-form-struct stx (encoded))
(define-form-struct form ()) Line 634: Export registry is always matched as false, but might not be
(define-form-struct (expr form) ())
(define-form-struct (mod form) (name self-modidx prefix provides requires body syntax-body unexported What are the real differences between the module-binding cases?
max-let-depth dummy lang-info internal-context))
(define-form-struct (lam expr) (name flags num-params param-types rest? closure-map closure-types max-let-depth body)) ; `lambda' I think parse-module-path-index was only used for debugging, so it is short-circuited now
(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))
|#
;; ---------------------------------------- ;; ----------------------------------------
;; Bytecode unmarshalers for various forms ;; Bytecode unmarshalers for various forms
@ -236,14 +186,24 @@
(define (read-splice v) (define (read-splice v)
(make-splice (seq-forms 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) (define (read-module v)
(match v (match v
[`(,name ,self-modidx ,lang-info ,functional? ,et-functional? [`(,name ,self-modidx ,lang-info ,functional? ,et-functional?
,rename ,max-let-depth ,dummy ,rename ,max-let-depth ,dummy
,prefix ,prefix
,indirect-provides ,num-indirect-provides
,indirect-syntax-provides ,num-indirect-syntax-provides
,indirect-et-provides ,num-indirect-et-provides ,indirect-et-provides ,num-indirect-et-provides
,indirect-syntax-provides ,num-indirect-syntax-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 (* 9 provide-phase-count))])
@ -288,15 +248,18 @@
(cons 1 syntax-requires) (cons 1 syntax-requires)
(cons -1 template-requires) (cons -1 template-requires)
(cons #f label-requires) (cons #f label-requires)
more-requires) (for/list ([(phase reqs) (in-list* more-requires 2)])
(cons phase reqs)))
(vector->list body) (vector->list body)
(map (lambda (sb) (map (lambda (sb)
(match sb (match sb
[(? def-syntaxes?) sb]
[(? def-for-syntax?) sb]
[`#(,ids ,expr ,max-let-depth ,prefix ,for-stx?) [`#(,ids ,expr ,max-let-depth ,prefix ,for-stx?)
((if for-stx? ((if for-stx?
make-def-for-syntax make-def-for-syntax
make-def-syntaxes) make-def-syntaxes)
ids expr prefix max-let-depth)])) (if (list? ids) ids (list ids)) expr prefix max-let-depth)]))
(vector->list syntax-body)) (vector->list syntax-body))
(list (vector->list indirect-provides) (list (vector->list indirect-provides)
(vector->list indirect-syntax-provides) (vector->list indirect-syntax-provides)
@ -387,10 +350,13 @@
(loop (subbytes so n)))))) (loop (subbytes so n))))))
(define (read-simple-number p) (define (read-simple-number p)
;; not sure if it's really unsigned
(integer-bytes->integer (read-bytes 4 p) #f #f)) (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) (define (cp-getc cp)
(begin-with-definitions (begin-with-definitions
@ -516,18 +482,7 @@
(define-struct not-ready ()) (define-struct not-ready ())
;; ---------------------------------------- ;; ----------------------------------------
;; Synatx unmarshaling ;; Syntax 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))
(define (decode-stx cp v) (define (decode-stx cp v)
(if (integer? v) (if (integer? v)
@ -591,7 +546,10 @@
(map loop (cdr (vector->list (struct->vector v)))))))] (map loop (cdr (vector->list (struct->vector v)))))))]
[else (add-wrap v)])))))) [else (add-wrap v)]))))))
(define (decode-wraps cp w) (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) (if (integer? w)
(let-values ([(w2 decoded?) (unmarshal-stx-get cp w)]) (let-values ([(w2 decoded?) (unmarshal-stx-get cp w)])
(if decoded? (if decoded?
@ -601,7 +559,9 @@
w2))) w2)))
(map (lambda (a) (map (lambda (a)
(let aloop ([a a]) (let aloop ([a a])
; A wrap-elem is either
(cond (cond
; A reference
[(integer? a) [(integer? a)
(let-values ([(a2 decoded?) (unmarshal-stx-get cp a)]) (let-values ([(a2 decoded?) (unmarshal-stx-get cp a)])
(if decoded? (if decoded?
@ -609,11 +569,12 @@
(let ([a2 (aloop a2)]) (let ([a2 (aloop a2)])
(unmarshal-stx-set! cp a a2) (unmarshal-stx-set! cp a a2)
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))) [(and (pair? a) (null? (cdr a)) (number? (car a)))
;; a mark (make-wrap-mark (car a))]
(string->symbol (format "mark~a" (car a)))]
[(vector? 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 ([top (+ (/ (- (vector-length a) 2) 2) 2)])
(let loop ([i 2]) (let loop ([i 2])
(if (= i top) (if (= i top)
@ -636,7 +597,7 @@
(make-module-rename phase (make-module-rename phase
(if kind 'marked 'normal) (if kind 'marked 'normal)
set-id set-id
(map (lambda (u) (let ([results (map (lambda (u)
(let ([just-phase? (let ([v (cddr u)]) (let ([just-phase? (let ([v (cddr u)])
(or (number? v) (not v)))]) (or (number? v) (not v)))])
(let-values ([(exns prefix) (let-values ([(exns prefix)
@ -655,52 +616,11 @@
(caddr u)) (caddr u))
exns exns
prefix)))) prefix))))
unmarshals) unmarshals)])
(let loop ([i 0]) #;(printf "~nunmarshals: ~S~n" unmarshals)
(if (= i (vector-length renames)) #;(printf "~nunmarshal results: ~S~n" results)
null results)
(cons (decode-renames renames)
(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 mark-renames
(and plus-kern? 'plus-kern)))] (and plus-kern? 'plus-kern)))]
[else (error "bad module rename: ~e" a)]))] [else (error "bad module rename: ~e" a)]))]
@ -719,6 +639,51 @@
[else (error 'decode-wraps "bad wrap element: ~e" a)]))) [else (error 'decode-wraps "bad wrap element: ~e" a)])))
w))) 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) (define (unmarshal-stx-get cp pos)
(if (pos . >= . (vector-length (cport-symtab cp))) (if (pos . >= . (vector-length (cport-symtab cp)))
(values `(#%bad-index ,pos) #t) (values `(#%bad-index ,pos) #t)
@ -737,19 +702,7 @@
(vector-set! (cport-decoded cp) pos #t)) (vector-set! (cport-decoded cp) pos #t))
(define (parse-module-path-index cp s) (define (parse-module-path-index cp s)
(cond s)
[(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 ;; Main parsing loop
@ -857,9 +810,10 @@
[(hash-table) [(hash-table)
(let ([eq (read-compact-number cp)] (let ([eq (read-compact-number cp)]
[len (read-compact-number cp)]) [len (read-compact-number cp)])
((if (zero? eq) ((case eq
make-hash-placeholder [(0) make-hasheq-placeholder]
make-hasheq-placeholder) [(1) make-hash-placeholder]
[(2) make-hash-placeholder])
(for/list ([i (in-range len)]) (for/list ([i (in-range len)])
(cons (read-compact cp) (cons (read-compact cp)
(read-compact cp)))))] (read-compact cp)))))]
@ -921,10 +875,13 @@
v)) v))
v))] v))]
[(weird-symbol) [(weird-symbol)
(let ([u (read-compact-number cp)] (let ([uninterned (read-compact-number cp)]
[str (read-compact-chars cp (read-compact-number cp))]) [str (read-compact-chars cp (read-compact-number cp))])
;; FIXME: no way to construct quasi-interned symbols: (if (= 1 uninterned)
(string->uninterned-symbol str))] ; 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) [(small-marshalled)
(read-marshalled (- ch cpt-start) cp)] (read-marshalled (- ch cpt-start) cp)]
[(small-application2) [(small-application2)
@ -994,7 +951,7 @@
(define size* (read-simple-number port)) (define size* (read-simple-number port))
(when (shared-size . >= . size*) (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)) (define rst (read-bytes size* port))
@ -1006,14 +963,14 @@
(define symtab (make-vector symtabsize (make-not-ready))) (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)]) (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))) (set-cport-pos! cp (vector-ref so* (sub1 i)))
(let ([v (read-compact cp)]) (let ([v (read-compact cp)])
(vector-set! symtab i v)))) (vector-set! symtab i v))))
(set-cport-pos! cp shared-size) (set-cport-pos! cp shared-size)
(read-marshalled 'compilation-top-type cp))) (read-marshalled 'compilation-top-type cp)))