#lang scheme
(require mzlib/etc 
         scheme/list)

(provide zo-parse)

;; ----------------------------------------
;;  Structures to represent bytecode

(define-syntax-rule (define-form-struct* id id+par (field-id ...))
  (begin
    (define-struct id+par (field-id ...) #:transparent)
    (provide (struct-out id))))

(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)]))

(define-form-struct compilation-top (max-let-depth prefix code)) ; compiled code always wrapped with this

(define-form-struct prefix (num-lifts toplevels stxs))   ; sets up top-level and syntax-object array

;; 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

;; In stxs of prefix:
(define-form-struct stx (encoded))

(define-form-struct form ())
(define-form-struct (expr form) ())

(define-form-struct (mod form) (name self-modidx prefix provides requires body syntax-body max-let-depth))

(define-form-struct (lam expr) (name flags num-params rest? closure-map 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)) ; 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?)) ; 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))

;; ----------------------------------------
;; Bytecode unmarshalers for various forms

(define (read-toplevel v)
  (define SCHEME_TOPLEVEL_CONST #x01)
  (define SCHEME_TOPLEVEL_READY #x02)
  (match v
    [(cons depth (cons pos flags))
     (make-toplevel depth pos 
                    (positive? (bitwise-and flags SCHEME_TOPLEVEL_CONST))
                    (positive? (bitwise-and flags SCHEME_TOPLEVEL_READY)))]
    [(cons depth pos)
     (make-toplevel depth pos #f #f)]))

(define (read-topsyntax v)
  (match v
    [`(,depth ,pos . ,midpt)
     (make-topsyntax depth pos midpt)]))

(define (read-variable v)
  (if (symbol? v)
      (make-global-bucket v)
      (error "expected a symbol")))

(define (do-not-read-variable v)
  (error "should not get here"))

(define (read-compilation-top v)
  (match v
    [`(,ld ,prefix . ,code)
     (unless (prefix? prefix)
       (error 'bad "not prefix ~a" prefix))
     (make-compilation-top ld prefix code)]))

(define (read-resolve-prefix v)
  (match v
    [`(,i ,tv . ,sv)
     (make-prefix i (vector->list tv) (vector->list sv))]))

(define (read-unclosed-procedure v)
  (define CLOS_HAS_REST 1)
  (define CLOS_HAS_REF_ARGS 2)
  (match v
    [`(,flags ,num-params ,max-let-depth ,name ,v . ,rest)
     (let ([rest? (positive? (bitwise-and flags CLOS_HAS_REST))])
       (let-values ([(closure-size closed-over body)
                     (if (zero? (bitwise-and flags CLOS_HAS_REF_ARGS))
                         (values (vector-length v) v rest)
                         (values v (car rest) (cdr rest)))])
         (make-lam name
                   flags
                   ((if rest? sub1 values) num-params)
                   rest?
                   (if (= closure-size (vector-length closed-over))
                       closed-over
                       (let ([v2 (make-vector closure-size)])
                         (vector-copy! v2 0 closed-over 0 closure-size)
                         v2))
                   max-let-depth
                   body)))]))

(define (read-let-value v)
  (match v
    [`(,count ,pos ,boxes? ,rhs . ,body)
     (make-install-value count pos boxes? rhs body)]))

(define (read-let-void v)
  (match v
    [`(,count ,boxes? . ,body)
     (make-let-void count boxes? body)]))

(define (read-letrec v)
  (match v
    [`(,count ,body . ,procs)
     (make-let-rec procs body)]))

(define (read-with-cont-mark v)
  (match v
    [`(,key ,val . ,body)
     (make-with-cont-mark key val body)]))

(define (read-sequence v) 
  (make-seq v))

(define (read-define-values v)
  (make-def-values
   (cdr (vector->list v))
   (vector-ref v 0)))

(define (read-define-syntaxes mk v)
  (mk (list-tail (vector->list v) 4)
      (vector-ref v 0)
      (vector-ref v 1)
      (vector-ref v 2)
      #;(vector-ref v 3)))

(define (read-define-syntax v)
  (read-define-syntaxes make-def-syntaxes v))

(define (read-define-for-syntax v)
  (read-define-syntaxes make-def-for-syntax v))

(define (read-set! v)
  (make-assign (cadr v) (cddr v) (car v)))

(define (read-case-lambda v)
  (make-case-lam (car v) (cdr v)))

(define (read-begin0 v) 
  (match v
    [(struct seq (exprs))
     (make-beg0 exprs)]))

(define (read-boxenv v)
  (make-boxenv (car v) (cdr v)))
(define (read-require v)
  (make-req (cdr v) (car v)))
(define (read-#%variable-ref v)
  (make-varref v))
(define (read-apply-values v)
  (make-apply-values (car v) (cdr v)))
(define (read-splice v)
  (make-splice v))

(define (read-module v)
  (match v
    [`(,name ,self-modidx ,lang-info ,functional? ,et-functional?
             ,rename ,max-let-depth ,dummy
             ,prefix ,kernel-exclusion ,reprovide-kernel?
             ,indirect-provides ,num-indirect-provides 
             ,indirect-syntax-provides ,num-indirect-syntax-provides 
             ,indirect-et-provides ,num-indirect-et-provides 
             ,protects ,et-protects
             ,provide-phase-count . ,rest)
     (let ([phase-data (take rest (* 8 provide-phase-count))])
       (match (list-tail rest (* 8 provide-phase-count))
         [`(,syntax-body ,body
                         ,requires ,syntax-requires ,template-requires ,label-requires
                         ,more-requires-count . ,more-requires)
          (make-mod name self-modidx
                    prefix phase-data
                    (list*
                     (cons 0 requires)
                     (cons 1 syntax-requires)
                     (cons -1 template-requires)
                     (cons #f label-requires)
                     more-requires)
                    (vector->list body)
                    (map (lambda (sb)
                           (match 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)]))
                         (vector->list syntax-body))
                    max-let-depth)]))]))
(define (read-module-wrap v)
  v)

;; ----------------------------------------
;; Unmarshal dispatch for various types

(define (read-more-syntax v)
  (let ([id (car v)]
        [v (cdr v)])
    ;; This is the ..._EXPD mapping from "schpriv.h":
    (case id
      [(0) (read-define-values v)]
      [(1) (read-define-syntax v)]
      [(2) (read-set! v)]
      [(3) v] ; a case-lam already
      [(4) (read-begin0 v)]
      [(5) (read-boxenv v)]
      [(6) (read-module-wrap v)]
      [(7) (read-require v)]
      [(8) (read-define-for-syntax v)]
      [(9) (read-#%variable-ref v)]
      [(10) (read-apply-values v)]
      [(11) (read-splice v)]
      [else (error 'read-mode-unsyntax "unknown id: ~e" id)])))

;; Type mappings from "stypes.h":
(define (int->type i)
  (case i
    [(0) 'toplevel-type]
    [(3) 'syntax-type]
    [(7) 'sequence-type]
    [(9) 'unclosed-procedure-type]
    [(10) 'let-value-type]
    [(11) 'let-void-type]
    [(12) 'letrec-type]
    [(14) 'with-cont-mark-type]
    [(15) 'quote-syntax-type]
    [(24) 'variable-type]
    [(25) 'module-variable-type]
    [(96) 'case-lambda-sequence-type]
    [(97) 'begin0-sequence-type]
    [(100) 'module-type]
    [(103) 'resolve-prefix-type]
    [else (error 'int->type "unknown type: ~e" i)]))

(define type-readers
  (make-immutable-hash
   (list
    (cons 'toplevel-type read-toplevel)
    (cons 'syntax-type read-more-syntax)
    (cons 'sequence-type read-sequence)
    (cons 'unclosed-procedure-type read-unclosed-procedure)
    (cons 'let-value-type read-let-value)
    (cons 'let-void-type read-let-void)
    (cons 'letrec-type read-letrec)
    (cons 'with-cont-mark-type read-with-cont-mark)
    (cons 'quote-syntax-type read-topsyntax)
    (cons 'variable-type read-variable)
    (cons 'module-variable-type do-not-read-variable)
    (cons 'compilation-top-type read-compilation-top)
    (cons 'case-lambda-sequence-type read-case-lambda)
    (cons 'begin0-sequence-type read-sequence)
    (cons 'module-type read-module)
    (cons 'resolve-prefix-type read-resolve-prefix))))

(define (get-reader type)
  (or (hash-ref type-readers type #f)
      (lambda (v)
        (error 'read-marshalled "reader for ~a not implemented" type))))

;; ----------------------------------------
;; Lowest layer of bytecode parsing

(define (split-so all-short so)
  (define n (if (zero? all-short) 4 2))
  (let loop ([so so])
    (if (zero? (bytes-length so))
        null
        (cons (integer-bytes->integer (subbytes so 0 n) #f)
              (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 (cp-getc cp)
  (begin-with-definitions
    (when ((cport-pos cp) . >= . (cport-size cp))
      (error "off the end"))
    (define r
      (bytes-ref (cport-bytes cp) (cport-pos cp)))
    (set-cport-pos! cp (add1 (cport-pos cp)))
    r))

(define small-list-max 65)
(define cpt-table
  ;; The "schcpt.h" mapping
  `([0  escape]
    [1  symbol]
    [2  symref]
    [3  weird-symbol]
    [4  keyword]
    [5  byte-string]
    [6  string]
    [7  char]
    [8  int]
    [9  null]
    [10 true]
    [11 false]
    [12 void]
    [13 box]
    [14 pair]
    [15 list]
    [16 vector]
    [17 hash-table]
    [18 stx]
    [19 gstx] ; unused
    [20 marshalled]
    [21 quote]
    [22 reference]
    [23 local]
    [24 local-unbox]
    [25 svector]
    [26 application]
    [27 let-one]
    [28 branch]
    [29 module-index]
    [30 module-var]
    [31 path]
    [32 closure]
    [33 delayed]
    [34 prefab]
    [35 60 small-number]
    [60 80 small-symbol]
    [80 92 small-marshalled]
    [92 ,(+ 92 small-list-max) small-proper-list]
    [,(+ 92 small-list-max) 192 small-list]
    [192 207 small-local]
    [207 222 small-local-unbox]
    [222 247 small-svector]
    [248 small-application2]
    [249 small-application3]
    [247 255 small-application]))

(define (cpt-table-lookup i)
  (for/or ([ent cpt-table])
          (match ent
            [(list k sym) (and (= k i) (cons k sym))]
            [(list k k* sym)
             (and (<= k i)
                  (< i k*)
                  (cons k sym))])))

(define (read-compact-bytes port c)
  (begin0
   (subbytes (cport-bytes port) (cport-pos port) (+ (cport-pos port) c))
   (set-cport-pos! port (+ c (cport-pos port)))))

(define (read-compact-chars port c)
  (bytes->string/utf-8 (read-compact-bytes port c)))

(define (read-compact-list c proper port)
  (cond [(= 0 c)
         (if proper null (read-compact port))]
        [else (cons (read-compact port) (read-compact-list (sub1 c) proper port))]))

(define (read-compact-number port)
  (define flag (cp-getc port))
  (cond [(< flag 128)
         flag]
        [(zero? (bitwise-and flag #x40))
         (let ([a (cp-getc port)])
           (+ (a . << . 6) (bitwise-and flag 63)))]
        [(zero? (bitwise-and flag #x20))
         (- (bitwise-and flag #x1F))]
        [else
         (let ([a (cp-getc port)]
               [b (cp-getc port)]
               [c (cp-getc port)]
               [d (cp-getc port)])
           (let ([n (integer-bytes->integer (bytes a b c d) #f #f)])
             (if (zero? (bitwise-and flag #x10))
                 (- n)
                 n)))]))

(define (read-compact-svector port n)
  (list->vector (reverse (for/list ([i (in-range n)]) (read-compact-number port)))))

(define (read-marshalled type port)
  (let* ([type (if (number? type) (int->type type) type)]
         [l (read-compact port)]
         [reader (get-reader type)])
    (reader l)))

(define (make-local unbox? pos flags)
  (define SCHEME_LOCAL_CLEAR_ON_READ #x01)
  (make-localref unbox? pos (positive? (bitwise-and flags SCHEME_LOCAL_CLEAR_ON_READ))))

(define (a . << . b)
  (arithmetic-shift a b))

(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 (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)
  (if (integer? v)
      (let-values ([(v2 decoded?) (unmarshal-stx-get cp v)])
        (if decoded?
            v2
            (let ([v2 (decode-stx cp v2)])
              (unmarshal-stx-set! cp v v2)
              v2)))
      (let loop ([v v])
        (let-values ([(cert-marks v encoded-wraps)
                      (match v
                        [`#((,datum . ,wraps) ,cert-marks) (values cert-marks datum wraps)]
                        [`(,datum . ,wraps) (values #f datum wraps)]
                        [else (error 'decode-wraps "bad datum+wrap: ~e" v)])])
          (let* ([wraps (decode-wraps cp encoded-wraps)]
                 [add-wrap (lambda (v) (make-wrapped v wraps cert-marks))])
            (cond
             [(pair? v)
              (if (eq? #t (car v))
                  ;; Share decoded wraps with all nested parts.
                  (let loop ([v (cdr v)])
                    (cond
                     [(pair? v) 
                      (let ploop ([v v])
                        (cond
                         [(null? v) null]
                         [(pair? v) (add-wrap (cons (loop (car v)) (ploop (cdr v))))]
                         [else (loop v)]))]
                     [(box? v) (add-wrap (box (loop (unbox v))))]
                     [(vector? v)
                      (add-wrap (list->vector (map loop (vector->list v))))]
                     [(prefab-struct-key v)
                      => (lambda (k)
                           (add-wrap
                            (apply
                             make-prefab-struct 
                             k
                             (map loop (cdr (vector->list (struct->vector v)))))))]
                     [else (add-wrap v)]))
                  ;; Decode sub-elements that have their own wraps:
                  (let-values ([(v counter) (if (exact-integer? (car v))
                                                (values (cdr v) (car v))
                                                (values v -1))])
                    (add-wrap
                     (let ploop ([v v][counter counter])
                       (cond
                        [(null? v) null]
                        [(or (not (pair? v)) (zero? counter)) (loop v)]
                        [(pair? v) (cons (loop (car v))
                                         (ploop (cdr v) (sub1 counter)))])))))]
             [(box? v) (add-wrap (box (loop (unbox v))))]
             [(vector? v)
              (add-wrap (list->vector (map loop (vector->list v))))]
             [(prefab-struct-key v)
              => (lambda (k)
                   (add-wrap
                    (apply
                     make-prefab-struct 
                     k
                     (map loop (cdr (vector->list (struct->vector v)))))))]
             [else (add-wrap v)]))))))

(define (decode-wraps cp w)
  (if (integer? w)
      (let-values ([(w2 decoded?) (unmarshal-stx-get cp w)])
        (if decoded?
            w2
            (let ([w2 (decode-wraps cp w2)])
              (unmarshal-stx-set! cp w w2)
              w2)))
      (map (lambda (a)
             (let aloop ([a a])
               (cond
                [(integer? a) 
                 (let-values ([(a2 decoded?) (unmarshal-stx-get cp a)])
                   (if decoded?
                       a2
                       (let ([a2 (aloop a2)])
                         (unmarshal-stx-set! cp a a2)
                         a2)))]
                [(and (pair? a) (null? (cdr a)) (number? (car a)))
                 ;; a mark
                 (string->symbol (format "mark~a" (car a)))]
                [(vector? a)
                 (make-lexical-rename
                  (let ([top (+ (/ (- (vector-length a) 2) 2) 2)])
                    (let loop ([i 2])
                      (if (= i top)
                          null
                          (cons (cons (vector-ref a i)
                                      (vector-ref a (+ (- top 2) i)))
                                (loop (+ i 1)))))))]
                [(pair? a)
                 (let-values ([(plus-kern? a) (if (eq? (car a) #t)
                                                  (values #t (cdr a))
                                                  (values #f a))])
                   (match a
                     [`(,phase ,kind ,set-id ,maybe-unmarshals . ,renames)
                      (let-values ([(unmarshals renames mark-renames)
                                    (if (vector? maybe-unmarshals)
                                        (values null maybe-unmarshals renames)
                                        (values maybe-unmarshals
                                                (car renames)
                                                (cdr renames)))])
                        (make-module-rename phase 
                                            (if kind 'marked 'normal)
                                            set-id
                                            (map (lambda (u)
                                                   (let ([just-phase? (let ([v (cddr u)])
                                                                        (or (number? v) (not v)))])
                                                     (let-values ([(exns prefix)
                                                                   (if just-phase?
                                                                       (values null #f)
                                                                       (let loop ([u (if just-phase? null (cdddr u))]
                                                                                  [a null])
                                                                         (if (pair? u)
                                                                             (loop (cdr u) (cons (car u) a))
                                                                             (values (reverse a) u))))])
                                                       (make-all-from-module
                                                        (parse-module-path-index cp (car u))
                                                        (cadr u)
                                                        (if just-phase?
                                                            (cddr u)
                                                            (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)))))
                                            mark-renames
                                            (and plus-kern? 'plus-kern)))]
                     [else (error "bad module rename: ~e" a)]))]
                [(boolean? a)
                 `(#%top-level-rename ,a)]
                [(symbol? a)
                 '(#%mark-barrier)]
                [(box? a)
                 (match (unbox a)
                   [`#(,amt ,src ,dest #f)
                    (make-phase-shift amt 
                                      (parse-module-path-index cp src)
                                      (parse-module-path-index cp dest))]
                   [else (error 'parse "bad phase shift: ~e" a)])]
                [else (error 'decode-wraps "bad wrap element: ~e" a)])))
           w)))

(define (unmarshal-stx-get cp pos)
  (if (pos . >= . (vector-length (cport-symtab cp)))
      (values `(#%bad-index ,pos) #t)
      (let ([v (vector-ref (cport-symtab 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)
                (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)
  (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)]))

;; ----------------------------------------
;; Main parsing loop

(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)])
                                           (unless x
                                             (error 'read-compact "unknown code : ~a" ch))
                                           (values (car x) (cdr x))))
      (define v 
        (case cpt-tag
          [(delayed)
           (let ([pos (read-compact-number cp)])
             (let ([v (vector-ref (cport-symtab 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)
           (let* ([len (read-compact-number cp)]
                  [s (subbytes (cport-bytes cp) (cport-pos cp) (+ (cport-pos cp) len))])
             (set-cport-pos! cp (+ (cport-pos cp) len))
             (parameterize ([read-accept-compiled #t]
                            [read-accept-bar-quote #t]
                            [read-accept-box #t]
                            [read-accept-graph #t]
                            [read-case-sensitive #t]
                            [read-square-bracket-as-paren #t]
                            [read-curly-brace-as-paren #t]
                            [read-decimal-as-inexact #t]
                            [read-accept-dot #t]
                            [read-accept-infix-dot #t]
                            [read-accept-quasiquote #t])
               (read (open-input-bytes s))))]
          [(reference)
           (make-primval (read-compact-number cp))]
          [(small-list small-proper-list)
           (let* ([l (- ch cpt-start)]
                  [ppr (eq? cpt-tag 'small-proper-list)])
             (if (positive? need-car)
                 (if (= l 1)
                     (cons (read-compact cp)
                           (if ppr null (read-compact cp)))
                     (read-compact-list l ppr cp))
                 (loop l ppr)))]
          [(let-one)
           (make-let-one (read-compact cp) (read-compact cp))]
          [(branch)
           (make-branch (read-compact cp) (read-compact cp) (read-compact cp))]
          [(module-index) (module-path-index-join (read-compact cp) (read-compact cp))]
          [(module-var)
           (let ([mod (read-compact cp)]
                 [var (read-compact cp)]
                 [pos (read-compact-number cp)])
             (let-values ([(mod-phase pos)
                           (if (= pos -2)
                                  (values 1 (read-compact-number cp))
                                  (values 0 pos))])
               (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)])
             (make-local #t p flags))]
          [(path)
           (let* ([p (bytes->path (read-compact-bytes cp (read-compact-number cp)))])
             (if (relative-path? p)
                 (path->complete-path p (or (current-load-relative-directory)
                                            (current-directory)))
                 p))]
          [(small-number)
           (let ([l (- ch cpt-start)])
             l)]
          [(int)
           (read-compact-number cp)]
          [(false) #f]
          [(true) #t]
          [(null) null]
          [(void) (void)]
          [(vector) (let* ([n (read-compact-number cp)]
                           [lst (for/list ([i (in-range n)])
                                  (read-compact cp))])
                      (vector->immutable-vector (list->vector lst)))]
          [(list) (let* ([n (read-compact-number cp)])
                    (append
                     (for/list ([i (in-range n)])
                       (read-compact cp))
                     (read-compact cp)))]
          [(prefab)
           (let ([v (read-compact cp)])
             (apply make-prefab-struct
                    (vector-ref v 0)
                    (cdr (vector->list v))))]
          [(hash-table)
           (let ([eq (read-compact-number cp)]
                 [len (read-compact-number cp)])
             ((if (zero? eq) 
                  make-hash-placeholder
                  make-hasheq-placeholder)
              (for/list ([i (in-range len)])
                (cons (read-compact cp)
                      (read-compact cp)))))]
          [(marshalled) (read-marshalled (read-compact-number cp) cp)]
          [(stx)
           (let ([v (make-reader-graph (read-compact cp))])
             (make-stx (decode-stx cp v)))]
          [(local local-unbox)
           (let ([c (read-compact-number cp)]
                 [unbox? (eq? cpt-tag 'local-unbox)])
             (if (negative? c)
                 (make-local unbox? (- (add1 c)) (read-compact-number cp))
                 (make-local unbox? c 0)))]
          [(small-local)
           (make-local #f (- ch cpt-start) 0)]
          [(small-local-unbox)
           (make-local #t (- ch cpt-start) 0)]
          [(small-symbol)
           (let ([l (- ch cpt-start)])
             (string->symbol (read-compact-chars cp l)))]
          [(symbol)
           (let ([l (read-compact-number cp)])
             (string->symbol (read-compact-chars cp l)))]
          [(keyword)
           (let ([l (read-compact-number cp)])
             (string->keyword (read-compact-chars cp l)))]
          [(byte-string)
           (let ([l (read-compact-number cp)])
             (read-compact-bytes cp l))]
          [(string)
           (let ([l (read-compact-number cp)]
                 [cl (read-compact-number cp)])
             (read-compact-chars cp l))]
          [(char)
           (integer->char (read-compact-number cp))]
          [(box)
           (box (read-compact cp))]
          [(quote)
           (make-reader-graph (read-compact cp))]
          [(symref)
           (let* ([l (read-compact-number cp)]
                  [v (vector-ref (cport-symtab 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)
           (let ([u (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))]
          [(small-marshalled)
           (read-marshalled (- ch cpt-start) cp)]
          [(small-application2)
           (make-application (read-compact cp)
                             (list (read-compact cp)))]
          [(small-application3)
           (make-application (read-compact cp)
                             (list (read-compact cp)
                                   (read-compact cp)))]
          [(small-application)
           (let ([c (add1 (- ch cpt-start))])
             (make-application (read-compact cp)
                               (for/list ([i (in-range (sub1 c))])
                                 (read-compact cp))))]          
          [(application)
           (let ([c (read-compact-number cp)])
             (make-application (read-compact cp)
                               (for/list ([i (in-range c)])
                                 (read-compact cp))))]          
          [(closure)
           (let* ([l (read-compact-number cp)]
                  [ind (make-indirect #f)])
             (vector-set! (cport-symtab cp) l ind)
             (let* ([v (read-compact cp)]
                    [cl (make-closure v (gensym
                                         (let ([s (lam-name v)])
                                           (cond
                                            [(symbol? s) s]
                                            [(vector? s) (vector-ref s 0)]
                                            [else 'closure]))))])
               (set-indirect-v! ind cl)
               ind))]
          [(svector)
           (read-compact-svector cp (read-compact-number cp))]
          [(small-svector)
           (read-compact-svector cp (- ch cpt-start))]
          [else (error 'read-compact "unknown tag ~a" cpt-tag)]))
      (cond 
        [(zero? need-car) v]
        [(and proper (= need-car 1))
         (cons v null)]
        [else
         (cons v (loop (sub1 need-car) proper))]))))

;; path -> bytes
;; implementes read.c:read_compiled
(define (zo-parse port)
  (begin-with-definitions    
   ;; skip the "#~"
   (unless (equal? #"#~" (read-bytes 2 port))
     (error 'zo-parse "not a bytecode stream"))
   
   (define version (read-bytes (min 63 (read-byte port)) port))
   
   (define symtabsize (read-simple-number port))
   
   (define all-short (read-byte port))
   
   (define cnt (* (if (not (zero? all-short)) 2 4)
                  (sub1 symtabsize)))

   (define so (read-bytes cnt port))
   
   (define so* (list->vector (split-so all-short so)))

   (define shared-size (read-simple-number port))
   (define size* (read-simple-number port))

   (when (shared-size . >= . size*) 
     (error 'bad-read))

   (define rst (read-bytes size* port))

   (unless (eof-object? (read port))
     (error 'not-end))
   
   (unless (= size* (bytes-length rst))
     (error "wrong number of bytes"))

   (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)))

   (for/list ([i (in-range 1 symtabsize)])
     (when (not-ready? (vector-ref symtab i))
       (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)))

;; ----------------------------------------

#;
(begin
  (define (compile/write sexp)
    (define s (open-output-bytes))
    (write (parameterize ([current-namespace (make-base-namespace)])
             (eval '(require (for-syntax scheme/base)))
             (compile sexp))
           s)
    (get-output-bytes s))

  (define (compile/parse sexp)  
    (let* ([bs (compile/write sexp)]
           [p (open-input-bytes bs)])
      (zo-parse p)))

  #;(compile/parse #s(foo 10 13))
  (zo-parse (open-input-file "/home/mflatt/proj/plt/collects/scheme/private/compiled/more-scheme_ss.zo"))
)