#lang racket/base


(require "version-case/version-case.rkt"
	 (for-syntax racket/base))

(version-case
 [(and (version<= "5.0.1" (version))
       (version< (version) "5.1"))
  (begin
    
    (require "bytecode-structs.rkt"
             racket/contract
             racket/match
             racket/list
             (prefix-in internal: compiler/zo-structs))

    ;; Translation from mzscheme 5.0.1 bytecode structures to our own.

    (define current-indirect-map (make-parameter (make-hasheq)))


    (define (translate-compilation-top a-top)
      (parameterize ([current-indirect-map (make-hasheq)])
        (match a-top
          [(struct internal:compilation-top (max-let-depth prefix code))
           (make-compilation-top max-let-depth (translate-prefix prefix) (translate-code code))])))
    

    (define (translate-code a-code)
      (match a-code
        [(? internal:form?)
         (translate-form a-code)]
        [(? internal:indirect?)
         (translate-indirect a-code)]
        [else
         a-code]))
    

    (define (translate-prefix a-prefix)
      (match a-prefix
        [(struct internal:prefix (num-lifts toplevels stxs))
         (make-prefix num-lifts 
                      (map (lambda (x)
                             (match x
                               ['#f
                                #f]
                               [(? symbol?)
                                x]
                               [(? internal:global-bucket?)
                                (translate-global-bucket x)]
                               [(? internal:module-variable?)
                                (translate-module-variable x)]))
                           toplevels)
                      (map translate-stx stxs))]))

    (define (translate-stx an-stx)
      (match an-stx
        [(struct internal:stx (encoded))
         (make-stx (translate-wrapped encoded))]))


    (define (translate-wrapped a-wrapped)
      (match a-wrapped
        [(struct internal:wrapped (datum wraps certs))
         (make-wrapped datum (map translate-wrap wraps) certs)]))

    (define (translate-wrap a-wrap)
      (match a-wrap
        [(? internal:lexical-rename?)
         (translate-lexical-rename a-wrap)]
        [(? internal:phase-shift?)
         (translate-phase-shift a-wrap)]
        [(? internal:module-rename?)
         (translate-module-rename a-wrap)]
        [(? internal:wrap-mark?)
         (translate-wrap-mark a-wrap)]
        [(? internal:prune?)
         (translate-prune a-wrap)]))

    (define (translate-wrap-mark a-wrap-mark)
      (match a-wrap-mark
        [(struct internal:wrap-mark (val))
         (make-wrap-mark val)]))

    (define (translate-prune a-prune)
      (match a-prune
        [(struct internal:prune (sym))
         (make-prune sym)]))


    (define (translate-lexical-rename a-lexical-rename)
      (match a-lexical-rename
        [(struct internal:lexical-rename (bool1 bool2 alist))
         (make-lexical-rename bool1 bool2 alist)]))

    (define (translate-phase-shift a-phase-shift)
      (match a-phase-shift
        [(struct internal:phase-shift (amt src dest))
         (make-phase-shift amt src dest)]))

    (define (translate-module-rename a-module-rename)
      (match a-module-rename
        [(struct internal:module-rename (phase kind set-id unmarshals renames mark-renames plus-kern?))
         (make-module-rename phase kind set-id 
                             (map translate-all-from-module unmarshals)
                             (map (lambda (sym+binding)
                                    (cons (car sym+binding)
                                          (translate-module-binding (cdr sym+binding))))
                                  renames)
                             mark-renames
                             plus-kern?)]))

    (define (translate-all-from-module an-all-from-module)
      (match an-all-from-module
        [(struct internal:all-from-module (path phase src-phase exceptions prefix))
         (make-all-from-module path phase src-phase exceptions prefix)]))
    

    (define (translate-module-binding a-module-binding)
      (match a-module-binding
        [(? internal:simple-module-binding?)
         (translate-simple-module-binding a-module-binding)]
        [(? internal:phased-module-binding?)
         (translate-phased-module-binding a-module-binding)]
        [(? internal:exported-nominal-module-binding?)
         (translate-exported-nominal-module-binding a-module-binding)]
        [(? internal:nominal-module-binding?)
         (translate-nominal-module-binding a-module-binding)]
        [(? internal:exported-module-binding?)
         (translate-exported-module-binding a-module-binding)]))

    (define (translate-simple-module-binding a-simple-module-binding)
      (match a-simple-module-binding
        [(struct internal:simple-module-binding (path))
         (make-simple-module-binding path)]))


    (define (translate-phased-module-binding a-binding)
      (match a-binding
        [(struct internal:phased-module-binding (path phase export-name nominal-path nominal-export-name))
         (make-phased-module-binding path phase export-name (translate-nominal-path nominal-path) nominal-export-name)]))
    

    (define (translate-nominal-module-binding a-binding)
      (match a-binding
        [(struct internal:nominal-module-binding (path nominal-path))
         (make-nominal-module-binding path (translate-nominal-path nominal-path))]))


    (define (translate-exported-nominal-module-binding a-module-binding)
      (match a-module-binding
        [(struct internal:exported-nominal-module-binding (path export-name nominal-path nominal-export-name))
         (make-exported-nominal-module-binding path export-name (translate-nominal-path nominal-path) nominal-export-name)]))


    (define (translate-exported-module-binding a-module-binding)
      (match a-module-binding
        [(struct internal:exported-module-binding (path export-name))
         (make-exported-module-binding path export-name)]))

    (define (translate-module-variable a-module-variable)
      (match a-module-variable
        [(struct internal:module-variable (modidx sym pos phase))
         (make-module-variable modidx sym pos phase)]))

    (define (translate-global-bucket a-bucket)
      (match a-bucket
        [(struct internal:global-bucket (name))
         (make-global-bucket name)]))



    (define (translate-nominal-path a-nominal-path)
      (match a-nominal-path
        [(? internal:simple-nominal-path?)
         (translate-simple-nominal-path a-nominal-path)]
        [(? internal:imported-nominal-path?)
         (translate-imported-nominal-path a-nominal-path)]
        [(? internal:phased-nominal-path?)
         (translate-phased-nominal-path a-nominal-path)]))


    (define (translate-simple-nominal-path a-path)
      (match a-path
        [(struct internal:simple-nominal-path (value))
         (make-simple-nominal-path value)]))


    (define (translate-imported-nominal-path a-path)
      (match a-path
        [(struct internal:imported-nominal-path (value import-phase))
         (make-imported-nominal-path (value import-phase))]))
    

    (define (translate-phased-nominal-path a-path)
      (match a-path
        [(struct internal:phased-nominal-path (value import-phase phase))
         (make-phased-nominal-path value import-phase phase)]))




    (define (translate-indirect an-indirect)
      (match an-indirect
        [(struct internal:indirect (v))
         (cond
          [(hash-ref (current-indirect-map) an-indirect #f)
           (hash-ref (current-indirect-map) an-indirect)]
          [else
           (begin
             ;; Make the shell, and continue the copy.
             (let ([partial-result (make-indirect #f)])
               (hash-set! (current-indirect-map) an-indirect partial-result)
               (let* ([translated-closure (translate-closure v)])
                 ;; Fix the shell.
                 (set-indirect-v! partial-result translated-closure)
                 partial-result)))])]))


    (define (translate-form a-form)
      (match a-form
        [(? internal:def-values?)
         (translate-def-values a-form)]
        [(? internal:def-syntaxes?)
         (translate-def-syntaxes a-form)]
        [(? internal:def-for-syntax?)
         (translate-def-for-syntax a-form)]
        [(? internal:req?)
         (translate-req a-form)]
        [(? internal:seq?)
         (translate-seq a-form)]
        [(? internal:splice?)
         (translate-splice a-form)]
        [(? internal:mod?)
         (translate-mod a-form)]
        [(? internal:expr?)
         (translate-expr a-form)]))


    (define (translate-req a-req)
      (match a-req
        [(struct internal:req (reqs dummy))
         (make-req reqs (translate-toplevel dummy))]))
    

    (define (translate-toplevel a-toplevel)
      (match a-toplevel
        [(struct internal:toplevel (depth pos const? ready?))
         (make-toplevel depth pos const? ready?)]))


    (define (translate-at-expression-position x)
      (match x
        [(? internal:expr?)
         (translate-expr x)]
        [(? internal:seq?)
         (translate-seq x)]
        [(? internal:indirect?)
         (translate-indirect x)]
        [else
         x]))


    (define (translate-def-values a-def-values)
      (match a-def-values
        [(struct internal:def-values (ids rhs))
         (make-def-values (map translate-toplevel ids)
                          (translate-at-expression-position rhs))]))


    (define (translate-def-syntaxes a-def-syntaxes)
      (match a-def-syntaxes
        [(struct internal:def-syntaxes (ids rhs prefix max-let-depth))
         (make-def-syntaxes ids #;(map translate-toplevel ids)
                            (translate-at-expression-position rhs)
                            (translate-prefix prefix)
                            max-let-depth)]))

                            (define (translate-def-for-syntax a-define-for-syntax)
                            (match a-define-for-syntax
                            [(struct internal:def-for-syntax (ids rhs prefix max-let-depth))
                            (make-def-for-syntax (map translate-toplevel ids)
                            (translate-at-expression-position rhs)
                            (translate-prefix prefix)
                            max-let-depth)]))


                            (define (translate-mod a-mod)
                            (match a-mod
                            [(struct internal:mod (name
                            srcname
                            self-modidx
                            prefix
                            provides
                            requires
                            body
                            syntax-body
                            unexported
                            max-let-depth
                            dummy
                            lang-info
                            internal-context))
                            (make-mod name
                            self-modidx 
                            (translate-prefix prefix)
                            (map (lambda (a-provide) 
                            (list (first a-provide)
                            ;; exported variables
                            (map translate-provided (second a-provide))
                            ;; exported syntax
                            (map translate-provided (third a-provide))))
                            provides)
                            requires
                            (map translate-at-form-position body)
                            ;; FIXME: we don't handle syntax objects yet.
                            empty #;(map (lambda (a-body) 
                            (match a-body 
                            [(? internal:def-syntaxes?)
                            (translate-def-syntaxes a-body)]
                            [(? internal:def-for-syntax?)
                            (translate-def-for-syntax a-body)]))
                            syntax-body)
                            unexported
                            max-let-depth
                            (translate-toplevel dummy)
                            lang-info
                            (cond [(boolean? internal-context)
                            internal-context]
                            [else
                            (translate-stx internal-context)]))]))
                            
                            (define (translate-provided a-provided)
                            (match a-provided
                            [(struct internal:provided (name src src-name nom-mod src-phase protected? insp))
                            (make-provided name src src-name nom-mod src-phase protected? insp)]))


                            (define (translate-splice a-splice)
                            (match a-splice
                            [(struct internal:splice (forms))
                            (make-splice (map translate-at-form-position forms))]))
                            
                            (define (translate-seq a-seq)
                            (match a-seq
                            [(struct internal:seq (forms))
                            (make-seq (map translate-at-form-position forms))]))


                            (define (translate-at-form-position x)
                            (match x
                            [(? internal:form?)
                            (translate-form x)]
                            [(? internal:indirect?)
                            (translate-indirect x)]
                            [else
                            x]))


                            (define (translate-closure a-closure)
                            (match a-closure
                            [(struct internal:closure (code gen-id))
                            (make-closure (translate-lam code) gen-id)]))


                            (define (translate-expr an-expr)
                            (match an-expr
                            [(? internal:lam?)
                            (translate-lam an-expr)]
                            [(? internal:closure?)
                            (translate-closure an-expr)]
                            [(? internal:indirect?)
                            (translate-indirect an-expr)]
                            [(? internal:case-lam?)
                            (translate-case-lam an-expr)]
                            [(? internal:let-one?)
                            (translate-let-one an-expr)]
                            [(? internal:let-void?)
                            (translate-let-void an-expr)]
                            [(? internal:install-value?)
                            (translate-install-value an-expr)]
                            [(? internal:let-rec?)
                            (translate-let-rec an-expr)]
                            [(? internal:boxenv?)
                            (translate-boxenv an-expr)]
                            [(? internal:localref?)
                            (translate-localref an-expr)]
                            [(? internal:toplevel?)
                            (translate-toplevel an-expr)]
                            [(? internal:topsyntax?)
                            (translate-topsyntax an-expr)]
                            [(? internal:application?)
                            (translate-application an-expr)]
                            [(? internal:branch?)
                            (translate-branch an-expr)]
                            [(? internal:with-cont-mark?)
                            (translate-with-cont-mark an-expr)]
                            [(? internal:beg0?)
                            (translate-beg0 an-expr)]
                            [(? internal:varref?)
                            (translate-varref an-expr)]
                            [(? internal:assign?)
                            (translate-assign an-expr)]
                            [(? internal:apply-values?)
                            (translate-apply-values an-expr)]
                            [(? internal:primval?)
                            (translate-primval an-expr)]))


                            (define (translate-lam a-lam)
                            (match a-lam
                            [(struct internal:lam 
                            (name flags num-params param-types rest? closure-map closure-types max-let-depth body))
                            (make-lam name flags num-params param-types rest? closure-map closure-types max-let-depth (translate-at-expression-position body))]))
                            

                            (define (translate-primval a-primval)
                            (match a-primval
                            [(struct internal:primval (id))
                            (make-primval id)]))

                            (define (translate-apply-values an-apply-values)
                            (match an-apply-values
                            [(struct internal:apply-values (proc args-expr))
                            (make-apply-values (translate-at-expression-position proc)
                            (translate-at-expression-position args-expr))]))

                            (define (translate-assign an-assign)
                            (match an-assign
                            [(struct internal:assign (id rhs undef-ok?))
                            (make-assign (translate-toplevel id) (translate-at-expression-position rhs) undef-ok?)]))
                            

                            (define (translate-varref a-varref)
                            (match a-varref
                            [(struct internal:varref (toplevel))
                            (make-varref (translate-toplevel toplevel))]))


                            (define (translate-beg0 a-beg0)
                            (match a-beg0
                            [(struct internal:beg0 (seq))
                            (make-beg0 (map translate-at-expression-position seq))]))

                            (define (translate-with-cont-mark a-with-cont-mark)
                            (match a-with-cont-mark
                            [(struct internal:with-cont-mark (key val body))
                            (make-with-cont-mark (translate-at-expression-position key)
                            (translate-at-expression-position val)
                            (translate-at-expression-position body))]))

                            (define (translate-branch a-branch)
                            (match a-branch
                            [(struct internal:branch (test then else))
                            (make-branch (translate-at-expression-position test)
                            (translate-at-expression-position then)
                            (translate-at-expression-position else))]))


                            (define (translate-application an-application)
                            (match an-application
                            [(struct internal:application (rator rands))
                            (make-application (translate-at-expression-position rator)
                            (map translate-at-expression-position rands))]))


                            (define (translate-topsyntax a-topsyntax)
                            (match a-topsyntax
                            [(struct internal:topsyntax (depth pos midp))
                            (make-topsyntax depth pos midp)]))
                            

                            (define (translate-localref a-localref)
                            (match a-localref
                            [(struct internal:localref (unbox? pos clear? other-clears? flonum?))
                            (make-localref unbox? pos clear? other-clears? flonum?)]))

                            (define (translate-boxenv a-boxenv)
                            (match a-boxenv
                            [(struct internal:boxenv (pos body))
                            (make-boxenv pos (translate-at-expression-position body))]))

                            (define (translate-let-rec a-let-rec)
                            (match a-let-rec
                            [(struct internal:let-rec (procs body))
                            (make-let-rec (map translate-lam procs)
                            (translate-at-expression-position body))]))


                            (define (translate-install-value an-install-value)
                            (match an-install-value
                            [(struct internal:install-value (count pos boxes? rhs body))
                            (make-install-value count pos boxes? 
                            (translate-at-expression-position rhs)
                            (translate-at-expression-position body))]))

                            (define (translate-let-void a-let-void)
                            (match a-let-void
                            [(struct internal:let-void (count boxes? body))
                            (make-let-void count boxes? (translate-at-expression-position body))]))


                            (define (translate-let-one a-let-one)
                            (match a-let-one
                            [(struct internal:let-one (rhs body flonum? unused?))
                            (make-let-one (translate-at-expression-position rhs)
                            (translate-at-expression-position body)
                            flonum?)]))


                            (define (translate-case-lam a-case-lam)
                            (match a-case-lam
                            [(struct internal:case-lam (name clauses))
                            (make-case-lam name
                            (map (lambda (a-clause) 
                            (cond [(internal:lam? a-clause)
                            (translate-lam a-clause)]
                            [(internal:indirect? a-clause)
                            (translate-indirect a-clause)]
                            [else
                            (error 'translate-case-lam "~s" a-clause)]))
                            clauses))]))




                            (provide/contract [translate-compilation-top (internal:compilation-top? . -> . compilation-top?)])

                            
                            )]
 [else
  (void)])