;; Simple type checker -- adapted from section 6.2 in the Dragon book

;; There are a couple ways to extend the type-checker with assignment.
;; We could choose to make assignment a statement, or we could choose to
;; make it an expression.  We could allow general expressions on the rhs
;; of an assignment, or we could allow only ids.  I choose to allow general
;; expressions.
;;
;; This time around, I'll type-check using a simple AST.  That will make
;; it easier to figure out what constitutes an assignable location.

(def-jyacc simple-lang

  (P    -> vars E                (%1))
  (vars -> vars var \;)
  (vars -> )

  (var  -> id \: type            ((setf (gethash %0 *vars*) %2)))
  (type -> char                  ('char))
  (type -> integer               ('int))
  (type -> array [ num ] of type (`(array   . ,%5)))
  (type -> ^ type                (`(pointer . ,%1)))

  (E    -> E0                    ((check-ast %0)))
  (E0   -> E1 = E0               (`(assign ,%0 ,%2)))
  (E0   -> E1)
  (E1   -> E1 mod E2             (`(mod ,%0 ,%2)))
  (E1   -> E2)
  (E2   -> ^ E3                  (`(pref ,%1)))
  (E2   -> E3)
  (E3   -> E3 [ E0 ]             (`(aref ,%0 ,%2)))
  (E3   -> E4)
  (E4   -> literal               (`(literal ,%0)))
  (E4   -> num                   (`(num ,%0)))
  (E4   -> id                    (`(id ,%0))))


(defun check-ast (ast)
  (pprint ast)
  (labels ((e1 () (check-ast (second ast)))
           (e2 () (check-ast (third  ast))))

    (case (car ast)
      (assign    (let ((lhs (e1))
                       (rhs (e2)))
                   (unless (eq lhs rhs)
                     (format t "~%Type mismatch in assignment."))
                   (unless (member (car (second ast)) '(pref aref id))
                     (format t "~%Left hand side is not assignable."))
                   lhs))

      (mod      (unless (and (eq (e1) 'int) (eq (e2) 'int))
                  (format t "~%Arguments to mod must be integers: ~a ~a"))
                'int)

      (pref    (let ((vtype (e1)))
                 (if (and (listp vtype)
                          (eq (car vtype) 'pointer))
                     (cdr vtype)
                     (format t "~%Cannot dereference non-pointer type."))))
      
      (aref    (let ((vtype (e1))
                     (itype (e2)))
                 (unless (eq itype 'int)
                   (format t "~%Array index must be an integer."))
                 (if (and (listp vtype)
                          (eq (car vtype) 'array))
                     (cdr vtype)
                     (format t "~%Cannot derference non-array type."))))
      
      (id      (let ((type (gethash (second ast) *vars*)))
                 (unless type
                   (format t "Unknown var ~s"))
                 type))
      
      (num     'int)
      (literal 'char))))


(defun week8-tc (tokens)
  (setf *vars* (make-hash-table))
  (labels 
      ((next () (let ((h (pop tokens)))
                  (print 
                   (cond ((null h)        '(*eof* . *eof*))
                         ((numberp h)     `(num . ,h))
                         ((stringp h)     `(literal . ,h))
                         ((member h '(\; \: char integer array of
                                      ^ * [ ] mod =))
                          `(,h . ,h))
                         (t               `(id . ,h))))))
       (err ()  (format t "Error at ~s~%" tokens)))
    (simple-lang #'next #'err)))


;; Examples:
#|

;; Correct examples:

(week8-tc '(
  key \: integer \;
  key mod 1999))

(week8-tc '(
  table \: array [ 255 ] of char \;
  key   \: integer \;
  table [ key mod 255 ]))

(week8-tc '(
  table \: array [ 255 ] of array [ 255 ] of char \;
  table [ 100 ] [ 200 ]))

(week8-tc '(
  ref \: ^ array [ 100 ] of char \;
  ^ ref))

(week8-tc '(
  ref \: array [ 100 ] of ^ char \;
  ^ ref [ 100 ]))

(week8-tc '( "f" ))

(week8-tc '(
  i \: integer \;
  p \: ^ integer \;
  i = ^ p))

(week8-tc '(
  i \: integer \;
  a \: array [ 100 ] of ^ integer \;
  ^ a [ 20 ] = i))

;; Incorrect examples

(week8-tc '(
  i \: char \;
  i = 10))

(week8-tc '(
  10 = 10 mod 10))

(week8-tc '(
  10 mod 20 = 10))

(week8-tc '(
  foo \: array [ 100 ] of integer \;
  100 mod foo))

(week8-tc '(
  foo \: array [ 100 ] of integer \;
  ^ foo ))

(week8-tc '(
  foo \: integer \;
  bar \: char \;
  foo mod bar))

|#