#cs
(module minijava-run mzscheme
  (require (lib "reduction-semantics.ss" "reduction-semantics")
           (lib "helper.ss" "reduction-semantics")
           (lib "list.ss")
           "minijava.ss")
  
  (provide :->mj)
  
  (define (target-method P sigma Sigma m)
    (let ([obj (lookup-sigma sigma Sigma)])
      (and obj
           (class-target-method P (car obj) m))))
  
  (define (class-target-method P c m)
    (let ([method (inm_ P c m)])
      (and method
           (list (list-ref method 3)
                 (list-ref method 4)))))
  
  (define (:->mj P)
    (list
     ;; new ------------------------------
     (reduction
      minijava-grammar
      ((in-hole (name E E) (new (name c c)))
       (name Sigma Sigma))
      (let ([sigma (generate-string)])
      `(,(replace E hole sigma)
        ,(extend-sigma sigma (list c (all-fields-of P c)) Sigma))))
     
     ;; field lookup ------------------------------
     (reduction
      minijava-grammar
      (side-condition
       ((in-hole (name E E) ((name sigma sigma) : (name c c) |.| (name f f)))
        (name Sigma Sigma))
       (lookup-field (lookup-sigma sigma Sigma) c f))
      `(,(replace E hole (lookup-field (lookup-sigma sigma Sigma) c f))
        ,Sigma))
     
     ;; field assignment ------------------------------
     (reduction
      minijava-grammar
      (side-condition
       ((in-hole (name E E) 
                 ((name sigma sigma) : (name c c) |.| (name f f) := (name V V)))
        (name Sigma Sigma))
       (lookup-sigma sigma Sigma))
      `(,(replace E hole V)
        ,(extend-sigma sigma (extend-field (lookup-sigma sigma Sigma) c f V)
                       Sigma)))
     
     ;; method call ----------------------------------------
     (reduction
      minijava-grammar
      (side-condition
       ((in-hole (name E E)
                 ((name sigma sigma) |.| (name m m)
                  ((name Vs V) ...)))
        (name Sigma Sigma))
       (target-method P sigma Sigma m))
      (let ([Xs+M (target-method P sigma Sigma m)])
        `(,(replace E hole
                    (minijava-subst
                     (foldl (lambda (M X V)
                              (minijava-subst M X V))
                            (cadr Xs+M)
                            (car Xs+M)
                            Vs)
                     'this
                     sigma))
          ,Sigma)))
     
     ;; super call ----------------------------------------
     (reduction
      minijava-grammar
      (side-condition
       ((in-hole (name E E)
                 (super (name sigma sigma) : (name c c)
                        |.| (name m m)
                  ((name Vs V) ...)))
        (name Sigma Sigma))
       (class-target-method P c m))
      (let ([Xs+M (class-target-method P c m)])
        `(,(replace E hole
                    (minijava-subst
                     (foldl (lambda (M X V)
                              (minijava-subst M X V))
                            (cadr Xs+M)
                            (car Xs+M)
                            Vs)
                     'this
                     sigma))
          ,Sigma)))
     
     ;; cast (success) ------------------------------
     (reduction
      minijava-grammar
      (side-condition
       ((in-hole (name E E) (((name c c)) (name sigma sigma)))
        (name Sigma Sigma))
       (let ([obj (lookup-sigma sigma Sigma)])
         (and obj (<=_ P (car obj) c))))
      `(,(replace E hole sigma)
        ,Sigma))
     (reduction
      minijava-grammar
      ((in-hole (name E E) (((name c c)) null))
       (name Sigma Sigma))
      `(,(replace E hole 'null)
        ,Sigma))

     ;; primitive ------------------------------
     (reduction
      minijava-grammar
      (side-condition
       ((in-hole (name E E) ((name o2 o2) (name V1 V) (name V2 V)))
        (name Sigma Sigma))
       (and (number? V1) (number? V2)))
      `(,(replace E hole ((case o2 [(+) +][(-) -][(*) *]) V1 V2))
        ,Sigma))
     (reduction
      minijava-grammar
      (side-condition
       ((in-hole (name E E) ((name o1 o1) (name V1 V)))
        (name Sigma Sigma))
       (and (number? V1)))
      `(,(replace E hole ((case o1 [(add1) add1][(sub1) sub1]) V1))
        ,Sigma))

     ;; error cases ------------------------------
     ;;  field lookup on null
     (reduction
      minijava-grammar
      ((in-hole E (null : c |.| f))
       (name Sigma Sigma))
      `(Error:null
        ,Sigma))
     ;;  field assignment with null
     (reduction
      minijava-grammar
      ((in-hole E (null : c |.| f := V))
       (name Sigma Sigma))
      `(Error:null
        ,Sigma))
     ;;  method call to null
     (reduction
      minijava-grammar
      ((in-hole E (null |.| m (V ...)))
        (name Sigma Sigma))
      `(Error:null
        ,Sigma))
     ;;  Cast to inappropriate class
     (reduction
      minijava-grammar
      (side-condition
       ((in-hole E (((name c c)) (name sigma sigma)))
        (name Sigma Sigma))
       (let ([obj (lookup-sigma sigma Sigma)])
         (and obj (not (<=_ P (car obj) c)))))
      `(Error:bad-cast
        ,Sigma)))))