(in-package "VCLOS")

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defgeneric foo (x)
    (:generic-function-class generic-function)))

(defmethod foo ((x number))
  (1+ x))
(defmethod foo ((x symbol))
  (symbol-name x))
(defmethod foo :after ((x fixnum))
  (print "Hello, World"))
(defmethod foo :around ((x integer))
  (+ 3 (call-next-method)))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defgeneric bar (x)
    (:generic-function-class specializer-generic-function)))

(defmethod bar ((x integer))
  (1+ x))
(defmethod bar ((x fixnum))
  (+ x 2))
(defmethod bar ((x (eql 3)))
  (- x))
(defmethod bar ((x symbol))
  (symbol-name x))

(eval-when (:compile-toplevel :load-toplevel :execute)
  (defgeneric baz (x)
    (:generic-function-class cons-specializer-generic-function)))

(defmethod baz ((x (cons (eql 1))))
  3)
(defmethod baz ((x (cons fixnum)))
  (1+ (car x)))
(defmethod baz ((x (cons (cons fixnum))))
  (* (caar x) 2))
(defmethod baz :after ((x (cons number)))
  (print "Hello!"))
(defmethod baz :before ((x list))
  (print "List!"))

;;; example from 20571
(eval-when (:compile-toplevel :load-toplevel :execute)
  (defgeneric walk (expr env call-stack)
    (:generic-function-class cons-specializer-generic-function)))

(defmethod walk ((expr list) env call-stack)
  (let ((call-stack (cons expr call-stack)))
    (walk (car expr) env call-stack)
    (walk (cdr expr) env call-stack)))
(defmethod walk ((expr t) env call-stack)
  (format t "invalid expression ~A: ~A: ~A~%"
          (class-name (class-of expr)) expr call-stack))
(defmethod walk ((var symbol) env call-stack)
  (let ((binding (find-binding env var)))
    (if binding
        (setf (used binding) t)
        (format t "unbound: ~A: ~A~%" var call-stack))))
(defmethod walk ((expr string) env call-stack)
  nil)
(defmethod walk ((expr number) env call-stack)
  nil)
(defmethod walk ((expr (eql t)) env call-stack)
  nil)
;;; Needed to add this one (not present in paper).
(defmethod walk ((expr null) env call-stack)
  nil)
(defmethod walk ((expr (cons (eql 'quote))) env call-stack)
  nil)
(defmethod walk ((form (cons (eql 'lambda))) env call-stack)
  (destructuring-bind (lambda lambda-list &rest body) form
    (let ((bindings (derive-bindings-from-ll lambda-list)))
      (dolist (form body)
        (walk form
              (make-environment bindings env)
              (cons form call-stack)))
      (dolist (bind bindings)
        (unless (used bind)
          (format t "unused: ~A: ~A~%" bind call-stack))))))

(defclass binding ()
  ((name :reader name :initarg :name)
   (used :accessor used :initform nil)))
(defun derive-bindings-from-ll (ll)
  ;; FIXME: no lambda list keyword parsing
  (mapcar (lambda (x) (make-instance 'binding :name x)) ll))
(defun make-environment (bindings env)
  (append bindings env))
(defun find-binding (env var)
  (find var env :key #'name))