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