;; A simple test for anonymous classes as type specifiers. This somewhat
;; mimics what I'd need for noffi. The real test is compiling this to a
;; FASL and then loading it.

;; If you want to be evil, find ***HERE*** and name the class by a
;; gensym. Naming just NIL would be a test, too.

;; CCL is fine with a patch. ECL appers to work, too. Otherwise only
;; Lispworks and Allegro work. Most notably SBCL is broken here.

#+CCL
(in-package :ccl)
#+CCL
;; CCL:LEVEL-1;L1-TYPESYS.LISP
(eval-when (:compile-toplevel :execute)
  (let ((ccl:*warn-if-redefine-kernel* nil))

    (defmacro define-type-method ((class method &rest more-methods)
			                              lambda-list &body body)
      `(progn
         (let* ((fn (nfunction (,class ,method ,@more-methods)
                               (lambda ,lambda-list ,@body))))
           ,@(mapcar #'(lambda (method)
		         `(setf (%svref
			         (type-class-or-lose ',class)
                                 ,(class-function-slot-or-lose method))
			        fn))
		     (cons method more-methods)))
         nil)) )

    (define-type-method (class :unparse) (type)
      (let* ((class (class-ctype-class type))
             (name (class-name class)))
        (if (and name
                 (symbolp name)
                 (eq (find-class name nil #| env |#) class) )
            name
            (class-ctype-class type)))))
#+CCL
(in-package :cl-user)

#+SBCL
(eval-when (:compile-toplevel :load-toplevel :execute)
  (require ::sb-cltl2))

(defpackage :anon-class-test
  (:use :cl
        ;; VALIDATE-SUPERCLASS
        #+CCL           :ccl
        #+SBCL          :sb-mop
        #+LISPWORKS     :hcl
        #+ECL           :clos
        #+CLISP         :clos
        #+EXCL          :mop
        ;; VARIABLE-INFORMATION
        #+SBCL          :sb-cltl2
        #+EXCL          :sys))

#+(OR CCL SBCL LISPWORKS EXCL)
(eval-when (:compile-toplevel :load-toplevel :execute)
  (pushnew :have-variable-information *features*))

(in-package :anon-class-test)

(eval-when (:compile-toplevel :load-toplevel :execute)

  (defvar *pointer-classes*
    (make-hash-table :test 'eq))

  (defclass pointer-class (standard-class)
    ((pointee :initarg :pointee :reader pointer-class-pointee)))

  (defclass pointer-box ()
    ((address :initarg :address :reader pointer-box-address)) )

  (defmethod validate-superclass ((class pointer-class) (super standard-class))
    t)

  (defun make-pointer-class (pointee)
    (declare (ignorable pointee))
    (make-instance 'pointer-class
                   ;; ***HERE***
                   :name (list ':pointer pointee)
                   :pointee pointee
                   :direct-superclasses (list (find-class 'pointer-box))))

  (defun find-pointer-class (pointee)
    (or (gethash pointee *pointer-classes*)
        (setf (gethash pointee *pointer-classes*)
              (make-pointer-class pointee))))

  (deftype pointer (pointee)
    (find-pointer-class pointee))

  (defmethod make-load-form ((object pointer-class) &optional environment)
    (declare (ignore environment))
    `(find-pointer-class ',(pointer-class-pointee object)))

  )                                     ;eval-when

#+HAVE-VARIABLE-INFORMATION
(defmacro compile-time-type-of (var &environment env)
  `',(cdr (or (assoc 'type (nth-value 2 (variable-information var env)))
              '(nil . t))))

;;

(defun make-pointer (pointee address)
  (make-instance (find-pointer-class pointee) :address address))

(defun make-char-pointer (address)
  (macrolet ((aux ()
               (find-pointer-class :char)))
    (make-instance (aux) :address address)))

(defun char-pointer-p (object)
  (typecase object
    ((pointer :char) t)
    (t nil)))

(defun the-char-pointer (object)
  (declare (optimize (safety 3)))
  (the (pointer :char) object))

(defun huh ()
  (let (it)
    (declare (ignore it))
    (locally
        (declare (type (pointer :int) it))
      (compile-time-type-of it))))

(defun cl-user::run ()
  (let ((*package* (symbol-package 'this-very-package)))
    (macrolet ((try (expected-to-win x)
                 `(multiple-value-bind (res err)
                      (ignore-errors (values ,x))
                    (if ,expected-to-win
                        (if err
                            (format t "~&~@<FAILED ~S => ERROR: ~A~:@>" ',x err)
                            (format t "~&~@<OK     ~S => ~S~:@>" ',x res))
                        (if err
                            (format t "~&~@<OK     ~0:I~S => ERROR: ~A~:@>" ',x err)
                            (format t "~&~@<FAILED ~S => ~S~:@>" ',x res))))))
      #+HAVE-VARIABLE-INFORMATION
      (progn
        (try t   (huh))
        (try t   (typep (make-pointer :char 42) (huh))))
      (try t   (char-pointer-p (make-pointer :char 42)))
      (try t   (the-char-pointer (make-pointer :char 42)))
      (try nil (the-char-pointer (make-pointer :int 42)))
      (try t   (type-of (make-char-pointer 10)))
      (try t   (typep (make-char-pointer 10) (find-pointer-class :char)))
      (try nil (check-type (make-char-pointer 10) (pointer :int))) )))