#cs
(module minijava mzscheme
  (require (lib "reduction-semantics.ss" "reduction-semantics")
           (lib "subst.ss" "reduction-semantics")
           (lib "helper.ss" "reduction-semantics")
           (lib "list.ss"))

  (provide minijava-grammar
           minijava-subst
           classes-once?
           object-builtin?
           fields-once-per-class?
           methods-once-per-class?
           classes-defined?
           well-founded-classes?
           overrides-consistent?
           inm_ inf_ <=_ <_
           all-cs all-fields-of
           lookup-sigma
           extend-sigma
           lookup-field
           extend-field
           P? c? result?
           fish-P)
  
  (define minijava-grammar
    (language (P (cl ... M))
	      (cl (class c extends c (fl ...) (mt ...)))
              (xcl (class c extends c (fl) (mt)))
              (fl (T f = V))
              (mt (T m ((T X) ...) M))
  
	      (M X
		 null
                 (new c)
                 (M : c |.| f)
                 (M : c |.| f := M)
                 (M |.| m (M ...))
                 (super X : c |.| m (M ...))
                 ((c) M)
                 b
                 (o1 M)
                 (o2 M M))
              
	      (V b
                 null
                 sigma)

	      (E hole
                 (E : c |.| f)
                 (E : c |.| f := M)
                 (V : c |.| f := E)
                 (E |.| m (M ...))
                 (V |.| m (V ... E M ...))
                 (super V : c |.| m (V ... E M ...))
                 ((c) E)
                 (o1 E)
                 (o2 E M)
                 (o2 V E))
              
              (T c
                 B)
              
              (b number)
              (B num)
              (sigma string)
              
              (o1 add1 sub1)
              (o2 + - *)
              
	      ;; The store:
              (Sigma ((sigma = (c FS)) ...))
	      ;; A "field store" within an object:
              (FS ((c |.| f V) ...))
        
	      ;; Evaluation produces a value or one
	      ;;  of two errors:
              (result V
                      Error:null
                      Error:bad-cast)
              
              ;; The c, f, m, and X variable sets are supposed
              ;; to be disjoint. We implement this by picking
              ;; specific c, f, and m names, and exclduing them
              ;; from X. (We also exclude all keywords from X).
              (c Object fish colorfish pickyfish dietfish otherfish)
              (f size color)
              (m getWeight grow eat)
              (X this
                 sigma
                 (variable-except Object this
                                  class extends
                                  null new super : |.| := =
                                  + - * add1 sub1
                                  num
                                  fish colorfish pickyfish dietfish otherfish
                                  size color
                                  getWeight grow eat
                                  Error:null Error:bad-cast))

	      (revP (M xcl) ;; reorder helps generate interesting cases
		    (M cl ...))))
  
  ;; Method calls need substitution:
  (define minijava-subst/backwards
    (subst
     [(? symbol?) (variable)]
     [(? number?) (constant)]
     [(? string?) (constant)]
     [`(,(and o (or 'add1 'sub1)) ,M1)
      (all-vars '())
      (build (lambda (vars M1) `(,o ,M1)))
      (subterm '() M1)]
     [`(,(and o (or '+ '- '*)) ,M1 ,M2)
      (all-vars '())
      (build (lambda (vars M1 M2) `(,o ,M1 ,M2)))
      (subterm '() M1)
      (subterm '() M2)]
     [`(,M : ,c |.| ,f)
      (all-vars '())
      (build (lambda (vars M) `(,M : ,c |.| ,f)))
      (subterm '() M)]
     [`(,M1 : ,c |.| ,f := ,M2)
      (all-vars '())
      (build (lambda (vars M1 M2) `(,M1 : ,c |.| ,f := M2)))
      (subterm '() M1)
      (subterm '() M2)]
     [`(,M |.| ,m (,Ms ...))
      (all-vars '())
      (build (lambda (vars M Ms) `(,M |.| ,m ,Ms)))
      (subterm '() M)
      (subterms '() Ms)]
     [`(super ,X : ,c |.| ,m (,Ms ...))
      (all-vars '())
      (build (lambda (vars X . Ms) `(super ,X : ,c |.| ,m ,Ms)))
      (subterm '() X)
      (subterms '() Ms)]
     [`((,c) ,M1)
      (all-vars '())
      (build (lambda (vars M1) `((,c) ,M1)))
      (subterm '() M1)]))

  (define (minijava-subst M Xr Mr)
    (minijava-subst/backwards Xr Mr M))
  
  (define P? (language->predicate minijava-grammar 'P))
  (define c? (language->predicate minijava-grammar 'c))
  (define m? (language->predicate minijava-grammar 'm))
  (define f? (language->predicate minijava-grammar 'f))
  (define V? (language->predicate minijava-grammar 'V))
  (define result? (language->predicate minijava-grammar 'result))
  
  (define (all-cs P) (all-of P c?))
  (define (all-ms P) (all-of P m?))
  (define (all-fs P) (all-of P f?))
  
  (define classes-once?
    ;; lang-match-lambda is like `lambda', but the argument
    ;; list must have excatly one item, there's a grammar 
    ;; expression after the argument list, and the body
    ;; is a sequence of pattern clauses.
    (lang-match-lambda (P) minijava-grammar
       [((class (name cs c) any ...) ... M)
	;; cs is a list of declared class names
        (unique-names? cs)]))
  
  (define object-builtin?
    (lang-match-lambda (P) minijava-grammar
      [(any ... (class Object any ...) any ...)
       #f]
      [any #t]))

  (define fields-once-per-class?
    (lang-match-lambda (P) minijava-grammar
       [((class c extends c ((T (name fss f) any ...) ...) any) ... M)
        (andmap unique-names? fss)]))

  (define methods-once-per-class?
    (lang-match-lambda (P) minijava-grammar
       [((class c extends c any ((T (name mss m) any ...) ...)) ... M)
        (andmap unique-names? mss)]))
  
  (define classes-defined?
    (lang-match-lambda (P) minijava-grammar
       [((class (name def-cs c) any ...) ... M)
        (andmap (lambda (c)
                  (and (memq c (cons 'Object def-cs)) #t))
                (all-cs P))]))

  ;; ext-map : P -> (list (cons defined-c extends-c) ...)
  ;;  Extracts a summary of declared subclasses
  (define ext-map
    (lang-match-lambda (P) minijava-grammar
      [((class (name def-cs c) extends (name ext-cs c) any ...) ... M)
       (map cons def-cs ext-cs)]))
  
  (define (<_ P c1 c2)
    (and (member (cons c1 c2) (ext-map P)) #t))
  
  ;; field-map: P -> (list (list c (list f T V) ...) ...)
  ;;  Extracts a summary of per-class field declations
  (define field-map
    (lang-match-lambda (P) minijava-grammar
      [((class (name def-cs c) extends c 
          (((name Tss T) (name fss f) = (name Vss V)) ...) 
          any) 
        ... M)
       (map cons def-cs (map (lambda (Ts fs Vs) (map list fs Ts Vs)) Tss fss Vss))]))
  
  ;; decl-inf : P c f -> (list T V) or #f
  (define (decl-inf_ P c f)
    (let ([a (assq c (field-map P))])
      (and a (let ([a (assq f (cdr a))])
               (and a (cdr a))))))

  ;; field-map: P -> (list (list c (list T m Ts Xs M) ...) ...)
  ;;  Extracts a summary of per-class method declations
  (define method-map
    (lang-match-lambda (P) minijava-grammar
      [((class (name def-cs c) extends c 
          any 
          (((name Tss T) (name mss m) 
            (((name Tsss T) (name Xsss X)) ...) (name Mss M)) ...))
        ... M)
       (map cons def-cs (map (lambda (Ts ms Tss Xss Ms)
                               (map list ms Tss Ts Xss Ms))
                             Tss mss Tsss Xsss Mss))]))
  
  ;; decl-inm : P c m -> (list (list T ...) T (list X ...) M) or #f
  (define (decl-inm_ P c m)
    (let ([a (assq c (method-map P))])
      (and a (let ([a (assq m (cdr a))])
               (and a (cdr a))))))
  
  ;; trans-ext-map : P -> (list (list c super-c ...) ...)
  ;;  Extract the superclass mapping, with transitive closure
  ;;  to include all superclasses of a particular class.
  (define (trans-ext-map P)
    (cdr (transitive-closure (cons (cons 'Object 'Object) (ext-map P)))))
  
  (define (<=_ P c1 c2)
    (or (eq? c1 c2)
        (let ([a (assq c1 (trans-ext-map P))])
          (and a (memq c2 a) #t))))

  (define (well-founded-classes? P)
    (andmap (lambda (rel)
	      ;; Check that a class is not in its own
	      ;;  list of superclasses.
              (not (memq (car rel) (cdr rel))))
            (trans-ext-map P)))
  
  ;; inf : P c f c' -> (list T V)
  (define (inf_ P c f c2)
    (and (<=_ P c2 c)
         (decl-inf_ P c f)))
  
  (define (overrides-consistent? P)
    (let ([cs (all-cs P)])
      (andmap 
       (lambda (c1)
         (andmap
          (lambda (c2)
            (or (not (<=_ P c1 c2))
		;; At this point, we know c1 <= c2
                (andmap (lambda (m)
			  ;; Is m declared in both classes?
                          (let ([m1 (decl-inm_ P c1 m)]
                                [m2 (decl-inm_ P c2 m)])
                            (or (not m1)
                                (not m2)
				;; Both c1 and c2 declare m; same types?
                                (equal? (cons (cadr m1) (car m1))
                                        (cons (cadr m2) (car m2))))))
                        (all-ms P))))
          (all-cs P)))
       (all-cs P))))
  
  ;; inm : P c' m -> (list c (list T ...) T (list X ...) M) or #f
  (define (inm_ P c2 m)
    (let* ([candidate-classes
	    ;; Start with list of all cs >= c2:
	    (filter
	     (lambda (c) (<=_ P c2 c))
	     (all-cs P))]
	   [candidate-methods
	    (filter ; drop #f results
	     (lambda (x) x)
	     (map (lambda (c)
		    ;; Check whether m is declared in c;
		    ;; cons c onto the front for use below.
		    (let ([d (decl-inm_ P c m)])
		      (and d
			   (cons c d))))
		  candidate-classes))])
      ;; Find min c among candidate method implementations
      (ormap (lambda (candidate)
               (and
                (andmap (lambda (candidate2)
                          (<=_ P (car candidate) (car candidate2)))
                        candidate-methods)
                candidate))
             candidate-methods)))
  
  ;; all-fields-of : P c -> (list (list c |.| f V) ...)
  (define (all-fields-of P c)
    (filter (lambda (x) x)
            (apply
             append
             (map
              (lambda (c2)
                (map
                 (lambda (f)
                   (let ([r (inf_ P c2 f c)])
                     (and r (list c2 '|.| f (cadr r)))))
                 (all-fs P)))
              (all-cs P)))))
  
  ;; lookup-sigma : sigma Sigma -> (list c FS)-or-#f
  (define (lookup-sigma sigma Sigma)
    (let ([a (assoc sigma Sigma)])
      (and a (caddr a))))
  
  ;; extend-sigma : sigma obj Sigma -> Sigma
  (define (extend-sigma sigma obj Sigma)
    (if (lookup-sigma sigma Sigma)
        (map (lambda (s=obj)
               (if (string=? (car s=obj) sigma)
                   (list sigma '= obj)
                   s=obj))
             Sigma)
        (cons (list sigma '= obj)
              Sigma)))
  
  ;; lookup-field : (list c FS)-or-#f c' f -> V
  (define (lookup-field obj c f)
    (and obj
         (ormap (lambda (cfv)
                  (and (eq? (car cfv) c)
                       (eq? (caddr cfv) f)
                       (cadddr cfv)))
                (cadr obj))))
  
  ;; extend-field : (list C FS) c f V -> (list C FS)
  (define (extend-field obj c f V)
    (cons (car obj)
          (if (lookup-field obj c f)
              (map (lambda (cfv)
                     (if (and (eq? (car cfv) c)
                              (eq? (caddr cfv) f))
                         (list c '|.| f V)
                         cfv))
                   (cdr obj))
              ;; Shouldn't happen, but this is how the rules
              ;;  are defined...
              (cons (list c '|.| f V) (cdr obj)))))
              
  (define fish-P
    '((class fish extends Object 
        ((num size = 1))
        ((num getWeight () (this : fish |.| size))
         (num grow ((num a)) (this : fish |.| size := (+ a (this : fish |.| size))))
        (num eat ((fish f)) (this |.| grow ((f |.| getWeight ()))))))
      (class colorfish extends fish
        ((num color = 7))
        ((num getWeight () (* (super this : fish |.| getWeight ())
                              (this : colorfish |.| color)))))
      ((new fish) |.| eat ((new colorfish))))))