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

Unifying some code

Browse Source 
original commit: 5833f7cba4
This commit is contained in:
Jay McCarthy 2010-05-27 11:59:41 -06:00
parent a6bd87b632
commit cac230bc93
1 changed files with 30 additions and 60 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -501,15 +501,9 @@
;; ---------------------------------------- ;; ----------------------------------------
;; Syntax unmarshaling ;; Syntax unmarshaling
(define (decode-stx cp v) (define (decode-stx cp v)
(if (integer? v) (if (integer? v)
(let-values ([(v2 decoded?) (unmarshal-stx-get cp v)]) (unmarshal-stx-get/decode cp v decode-stx)
(if decoded?
v2
(let ([v2 (decode-stx cp v2)])
(unmarshal-stx-set! cp v v2)
v2)))
(let loop ([v v]) (let loop ([v v])
(let-values ([(cert-marks v encoded-wraps) (let-values ([(cert-marks v encoded-wraps)
(match v (match v
@ -569,24 +563,14 @@
(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) ; 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)]) (unmarshal-stx-get/decode cp w decode-wraps)
(if decoded?
w2
(let ([w2 (decode-wraps cp w2)])
(unmarshal-stx-set! cp w w2)
w2)))
(map (lambda (a) (map (lambda (a)
(let aloop ([a a]) (let aloop ([a a])
; A wrap-elem is either ; A wrap-elem is either
(cond (cond
; A reference ; A reference
[(integer? a) [(integer? a)
(let-values ([(a2 decoded?) (unmarshal-stx-get cp a)]) (unmarshal-stx-get/decode cp a (lambda (cp v) (aloop v)))]
(if decoded?
a2
(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>) ; 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)))
(make-wrap-mark (car a))] (make-wrap-mark (car a))]
@ -704,22 +688,15 @@
[module-path-index [module-path-index
(make-simple-module-binding module-path-index)])))) (make-simple-module-binding module-path-index)]))))
(define (unmarshal-stx-get cp pos) (define (unmarshal-stx-get/decode cp pos decode-stx)
(if (pos . >= . (vector-length (cport-symtab cp))) (define v2 (read-sym cp pos))
(values `(#%bad-index ,pos) #t) (define decoded? (vector-ref (cport-decoded cp) pos))
(let ([v (vector-ref (cport-symtab cp) pos)]) (if decoded?
(if (not-ready? v) v2
(let ([save-pos (cport-pos cp)]) (let ([dv2 (decode-stx cp v2)])
(set-cport-pos! cp (vector-ref (cport-shared-offsets cp) (sub1 pos))) (vector-set! (cport-symtab cp) pos dv2)
(let ([v (read-compact cp)]) (vector-set! (cport-decoded cp) pos #t)
(vector-set! (cport-symtab cp) pos v) dv2)))
(set-cport-pos! cp save-pos)
(values v #f)))
(values v (vector-ref (cport-decoded cp) pos))))))
(define (unmarshal-stx-set! cp pos v)
(vector-set! (cport-symtab cp) pos v)
(vector-set! (cport-decoded cp) pos #t))
(define (parse-module-path-index cp s) (define (parse-module-path-index cp s)
s) s)
@ -738,15 +715,7 @@
(case cpt-tag (case cpt-tag
[(delayed) [(delayed)
(let ([pos (read-compact-number cp)]) (let ([pos (read-compact-number cp)])
(let ([v (vector-ref (cport-symtab cp) pos)]) (read-sym cp pos))]
(if (not-ready? v)
(let ([save-pos (cport-pos cp)])
(set-cport-pos! cp (vector-ref (cport-shared-offsets cp) (sub1 pos)))
(let ([v (read-compact cp)])
(vector-set! (cport-symtab cp) pos v)
(set-cport-pos! cp save-pos)
v))
v)))]
[(escape) [(escape)
(let* ([len (read-compact-number cp)] (let* ([len (read-compact-number cp)]
[s (cport-get-bytes cp len)]) [s (cport-get-bytes cp len)])
@ -894,16 +863,8 @@
(read-compact cp))))]) (read-compact cp))))])
(read (open-input-bytes #"x")))))] (read (open-input-bytes #"x")))))]
[(symref) [(symref)
(let* ([l (read-compact-number cp)] (let* ([l (read-compact-number cp)])
[v (vector-ref (cport-symtab cp) l)]) (read-sym cp l))]
(if (not-ready? v)
(let ([pos (cport-pos cp)])
(set-cport-pos! cp (vector-ref (cport-shared-offsets cp) (sub1 l)))
(let ([v (read-compact cp)])
(set-cport-pos! cp pos)
(vector-set! (cport-symtab cp) l v)
v))
v))]
[(weird-symbol) [(weird-symbol)
(let ([uninterned (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))])
@ -956,6 +917,17 @@
[else [else
(cons v (loop (sub1 need-car) proper))])))) (cons v (loop (sub1 need-car) proper))]))))
(define (read-sym cp i)
(define symtab (cport-symtab cp))
(define vv (vector-ref symtab i))
(define save-pos (cport-pos cp))
(when (not-ready? vv)
(set-cport-pos! cp (vector-ref (cport-shared-offsets cp) (sub1 i)))
(let ([v (read-compact cp)])
(vector-set! symtab i v))
(set-cport-pos! cp save-pos))
(vector-ref symtab i))
;; path -> bytes ;; path -> bytes
;; implementes read.c:read_compiled ;; implementes read.c:read_compiled
(define (zo-parse port) (define (zo-parse port)
@ -990,16 +962,14 @@
(unless (eof-object? (read-byte port)) (unless (eof-object? (read-byte port))
(error 'zo-parse "File too big")) (error 'zo-parse "File too big"))
(define symtab (make-vector symtabsize (make-not-ready))) (define nr (make-not-ready))
(define symtab
(make-vector symtabsize nr))
(define cp (make-cport 0 shared-size port size* rst-start symtab so* (make-vector symtabsize #f) (make-hash) (make-hash))) (define cp (make-cport 0 shared-size port size* rst-start symtab so* (make-vector symtabsize #f) (make-hash) (make-hash)))
(for/list ([i (in-range 1 symtabsize)]) (for/list ([i (in-range 1 symtabsize)])
(define vv (vector-ref symtab i)) (read-sym cp 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) (set-cport-pos! cp shared-size)
(read-marshalled 'compilation-top-type cp))) (read-marshalled 'compilation-top-type cp)))