tests/mop-9.impure-cload.lisp

   1 ;;;; miscellaneous side-effectful tests of the MOP
   2
   3 ;;;; This software is part of the SBCL system. See the README file for
   4 ;;;; more information.
   5 ;;;;
   6 ;;;; While most of SBCL is derived from the CMU CL system, the test
   7 ;;;; files (like this one) were written from scratch after the fork
   8 ;;;; from CMU CL.
   9 ;;;;
  10 ;;;; This software is in the public domain and is provided with
  11 ;;;; absolutely no warranty. See the COPYING and CREDITS files for
  12 ;;;; more information.
  13
  14 ;;; this file contains tests of (SETF CLASS-NAME) and (SETF
  15 ;;; GENERIC-FUNCTION-NAME)
  16
  17 (defclass metaclass/ri (standard-class)
  18   ())
  19 (defmethod sb-mop:validate-superclass ((c metaclass/ri) (s standard-class))
  20   t)
  21 (defclass class/ri ()
  22   ()
  23   (:metaclass metaclass/ri))
  24 (defvar *class/ri-args* nil)
  25 (defmethod reinitialize-instance :after ((o metaclass/ri) &rest initargs)
  26   (setf *class/ri-args* initargs))
  27
  28 (with-test (:name ((setf class-name) reinitialize-instance))
  29   (let ((class (find-class 'class/ri)))
  30     (setf (class-name class) 'name)
  31     (assert (equal *class/ri-args* '(:name name)))
  32     (setf (class-name class) 'class/ri)
  33     (assert (equal *class/ri-args* '(:name class/ri)))))
  34
  35 (defclass dependent ()
  36   ((slot :initform nil :accessor dependent-slot)))
  37 (defclass class/dependent ()
  38   ())
  39 (defvar *dependent* (make-instance 'dependent))
  40 (defmethod sb-mop:update-dependent ((object standard-class)
  41                                     (dependent dependent)
  42                                     &rest args)
  43   (setf (dependent-slot dependent) args))
  44
  45 (with-test (:name ((setf class-name) sb-mop:update-dependent))
  46   (let ((class (find-class 'class/dependent)))
  47     (sb-mop:add-dependent class *dependent*)
  48     (setf (class-name class) 'name)
  49     (assert (equal (dependent-slot *dependent*) '(:name name)))
  50     (sb-mop:remove-dependent class *dependent*)
  51     (setf (class-name class) 'name)
  52     (assert (equal (dependent-slot *dependent*) '(:name name)))))
  53
  54 (defclass gfc/ri (standard-generic-function)
  55   ()
  56   (:metaclass sb-mop:funcallable-standard-class))
  57 (defgeneric gf/ri ()
  58   (:generic-function-class gfc/ri))
  59 (defvar *gf/ri-args* nil)
  60 (defmethod reinitialize-instance :after ((o gfc/ri) &rest initargs)
  61   (setf *gf/ri-args* initargs))
  62
  63 (with-test (:name ((setf sb-mop:generic-function-name) reinitialize-instance))
  64   (let ((gf #'gf/ri))
  65     (setf (sb-mop:generic-function-name gf) 'name)
  66     (assert (equal *gf/ri-args* '(:name name)))
  67     (setf (sb-mop:generic-function-name gf) 'gf/ri)
  68     (assert (equal *gf/ri-args* '(:name gf/ri)))))
  69
  70 (defgeneric gf/dependent ())
  71 (defmethod sb-mop:update-dependent ((object standard-generic-function)
  72                              (dependent dependent)
  73                              &rest args)
  74   (setf (dependent-slot dependent) args))
  75
  76 (with-test (:name ((setf sb-mop:generic-function-name) sb-mop:update-dependent))
  77   (let ((gf (find-class 'class/dependent)))
  78     (sb-mop:add-dependent gf *dependent*)
  79     (setf (sb-mop:generic-function-name gf) 'gf/name)
  80     (assert (equal (dependent-slot *dependent*) '(:name gf/name)))
  81     (sb-mop:remove-dependent gf *dependent*)
  82     (setf (sb-mop:generic-function-name gf) 'gf/dependent)
  83     (assert (equal (dependent-slot *dependent*) '(:name gf/name)))))