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

Fix "zo-parse.rkt" wrt the inclusion of `identity' in mzlib/etc, and

Browse Source 
switch to racket (making `begin-with-definitions' redundant).
This commit is contained in:
Eli Barzilay 2011-06-07 13:06:13 -04:00
parent a7aad558a3
commit fc1b974cd2
1 changed files with 282 additions and 290 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

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

@ -1,8 +1,7 @@
#lang scheme/base #lang racket/base
(require mzlib/etc (require racket/function
racket/function racket/match
scheme/match racket/list
scheme/list
unstable/struct unstable/struct
compiler/zo-structs compiler/zo-structs
racket/dict racket/dict
@ -393,12 +392,11 @@
(+ (cport-pos cp) (cport-shared-start cp))) (+ (cport-pos cp) (cport-shared-start cp)))
(define (cp-getc cp) (define (cp-getc cp)
(begin-with-definitions
(when ((cport-pos cp) . >= . (cport-size cp)) (when ((cport-pos cp) . >= . (cport-size cp))
(error "off the end")) (error "off the end"))
(define r (cport-get-byte cp (cport-pos cp))) (define r (cport-get-byte cp (cport-pos cp)))
(set-cport-pos! cp (add1 (cport-pos cp))) (set-cport-pos! cp (add1 (cport-pos cp)))
r)) r)
(define small-list-max 65) (define small-list-max 65)
(define cpt-table (define cpt-table
@ -750,7 +748,6 @@
(define (read-compact cp) (define (read-compact cp)
(let loop ([need-car 0] [proper #f]) (let loop ([need-car 0] [proper #f])
(begin-with-definitions
(define ch (cp-getc cp)) (define ch (cp-getc cp))
(define-values (cpt-start cpt-tag) (define-values (cpt-start cpt-tag)
(let ([x (cpt-table-lookup ch)]) (let ([x (cpt-table-lookup ch)])
@ -822,12 +819,8 @@
(make-module-variable mod var pos mod-phase)))] (make-module-variable mod var pos mod-phase)))]
[(local-unbox) [(local-unbox)
(let* ([p* (read-compact-number cp)] (let* ([p* (read-compact-number cp)]
[p (if (< p* 0) [p (if (< p* 0) (- (add1 p*)) p*)]
(- (add1 p*)) [flags (if (< p* 0) (read-compact-number cp) 0)])
p*)]
[flags (if (< p* 0)
(read-compact-number cp)
0)])
(make-local #t p flags))] (make-local #t p flags))]
[(path) [(path)
(let* ([p (bytes->path (read-compact-bytes cp (read-compact-number cp)))]) (let* ([p (bytes->path (read-compact-bytes cp (read-compact-number cp)))])
@ -850,8 +843,7 @@
(lambda (i) (read-compact cp))) (lambda (i) (read-compact cp)))
; XXX Now it allocates an unnessary list AND vector ; XXX Now it allocates an unnessary list AND vector
(let* ([n (read-compact-number cp)] (let* ([n (read-compact-number cp)]
[lst (for/list ([i (in-range n)]) [lst (for/list ([i (in-range n)]) (read-compact cp))])
(read-compact cp))])
(vector->immutable-vector (list->vector lst)))] (vector->immutable-vector (list->vector lst)))]
[(pair) [(pair)
(let* ([a (read-compact cp)] (let* ([a (read-compact cp)]
@ -977,7 +969,7 @@
[(and proper (= need-car 1)) [(and proper (= need-car 1))
(cons v null)] (cons v null)]
[else [else
(cons v (loop (sub1 need-car) proper))])))) (cons v (loop (sub1 need-car) proper))])))
(define (unmarshal-stx-get/decode cp pos decode-stx) (define (unmarshal-stx-get/decode cp pos decode-stx)
(define v2 (read-sym cp pos)) (define v2 (read-sym cp pos))
@ -1003,9 +995,9 @@
(if (memq i (mark-parameter-all read-sym-mark)) (if (memq i (mark-parameter-all read-sym-mark))
ph ph
; Otherwise, try to read it and return the real thing ; Otherwise, try to read it and return the real thing
(local [(define vv (placeholder-get ph))] (let ([vv (placeholder-get ph)])
(when (not-ready? vv) (when (not-ready? vv)
(local [(define save-pos (cport-pos cp))] (let ([save-pos (cport-pos cp)])
(set-cport-pos! cp (vector-ref (cport-shared-offsets cp) (sub1 i))) (set-cport-pos! cp (vector-ref (cport-shared-offsets cp) (sub1 i)))
(mark-parameterize (mark-parameterize
([read-sym-mark i]) ([read-sym-mark i])
@ -1017,7 +1009,6 @@
;; path -> bytes ;; path -> bytes
;; implementes read.c:read_compiled ;; implementes read.c:read_compiled
(define (zo-parse [port (current-input-port)]) (define (zo-parse [port (current-input-port)])
(begin-with-definitions
;; skip the "#~" ;; skip the "#~"
(unless (equal? #"#~" (read-bytes 2 port)) (unless (equal? #"#~" (read-bytes 2 port))
(error 'zo-parse "not a bytecode stream")) (error 'zo-parse "not a bytecode stream"))
@ -1055,17 +1046,18 @@
(define symtab (define symtab
(build-vector symtabsize (λ (i) (make-placeholder nr)))) (build-vector symtabsize (λ (i) (make-placeholder 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 ([i (in-range 1 symtabsize)]) (for ([i (in-range 1 symtabsize)])
(read-sym cp i)) (read-sym cp i))
#;(printf "Parsed table:\n") #;(printf "Parsed table:\n")
#;(for ([(i v) (in-dict (cport-symtab cp))]) #;(for ([(i v) (in-dict (cport-symtab cp))])
(printf "~a = ~a\n" i (placeholder-get v)) ) (printf "~a = ~a\n" i (placeholder-get v)))
(set-cport-pos! cp shared-size) (set-cport-pos! cp shared-size)
(make-reader-graph (make-reader-graph (read-marshalled 'compilation-top-type cp)))
(read-marshalled 'compilation-top-type cp))))
;; ---------------------------------------- ;; ----------------------------------------