make-load-form-saving-slots.lsp 6.43 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15
;-*- Mode:     Lisp -*-
;;;; Author:   Paul Dietz
;;;; Created:  Sat May 17 11:54:54 2003
;;;; Contains: Tests of MAKE-LOAD-FORM-SAVING-SLOTS

(in-package :cl-test)

;;; These are tests of MAKE-LOAD-FORM-SAVING-SLOTS proper; tests involving
;;; file compilation will be located elsewhere.


(defstruct mlfss-01 a b c)

(deftest make-load-form-saving-slots.1
  (let* ((obj (make-mlfss-01))
sds's avatar
sds committed
16 17
         (forms (multiple-value-list
                 (make-load-form-saving-slots obj))))
18 19 20 21 22 23 24 25 26
    (values
     (length forms)
     (let ((newobj (eval (first forms))))
       (eval (subst newobj obj (second forms)))
       (eqt (class-of obj) (class-of newobj)))))
  2 t)

(deftest make-load-form-saving-slots.2
  (let* ((obj (make-mlfss-01))
sds's avatar
sds committed
27 28
         (forms (multiple-value-list
                 (make-load-form-saving-slots obj :slot-names '(a b)))))
29 30 31 32 33 34 35 36 37 38 39
    (values
     (length forms)
     (let ((newobj (eval (first forms))))
       (eval (subst newobj obj (second forms)))
       (eqt (class-of obj) (class-of newobj)))))
  2 t)

(defclass mlfss-02 () ((a :initarg :a) (b :initarg :b) (c :initarg :c)))

(deftest make-load-form-saving-slots.3
  (let* ((obj (make-instance 'mlfss-02))
sds's avatar
sds committed
40 41
         (forms (multiple-value-list
                 (make-load-form-saving-slots obj))))
42 43 44
     (let ((newobj (eval (first forms))))
       (eval (subst newobj obj (second forms)))
       (values
sds's avatar
sds committed
45 46 47
        (length forms)
        (eqt (class-of obj) (class-of newobj))
        (map-slot-boundp* newobj '(a b c)))))
48 49 50 51
  2 t (nil nil nil))

(deftest make-load-form-saving-slots.4
  (let* ((obj (make-instance 'mlfss-02 :a 1 :b 'a :c '(x y z)))
sds's avatar
sds committed
52 53
         (forms (multiple-value-list
                 (make-load-form-saving-slots obj :slot-names '(a b c)))))
54 55 56
     (let ((newobj (eval (first forms))))
       (eval (subst newobj obj (second forms)))
       (values
sds's avatar
sds committed
57 58 59 60
        (length forms)
        (eqt (class-of obj) (class-of newobj))
        (map-slot-boundp* newobj '(a b c))
        (map-slot-value newobj '(a b c)))))
61 62 63 64 65
  2 t (t t t) (1 a (x y z)))


(deftest make-load-form-saving-slots.5
  (let* ((obj (make-instance 'mlfss-02 :a #(x y z)))
sds's avatar
sds committed
66 67
         (forms (multiple-value-list
                 (make-load-form-saving-slots obj :slot-names '(a b)))))
68 69 70
     (let ((newobj (eval (first forms))))
       (eval (subst newobj obj (second forms)))
       (values
sds's avatar
sds committed
71 72 73 74
        (length forms)
        (eqt (class-of obj) (class-of newobj))
        (map-slot-boundp* newobj '(a b c))
        (slot-value newobj 'a))))
75 76
  2 t (t nil nil) #(x y z))

77 78
(deftest make-load-form-saving-slots.6
  (let* ((obj (make-instance 'mlfss-02))
sds's avatar
sds committed
79 80
         (forms (multiple-value-list
                 (make-load-form-saving-slots obj :allow-other-keys nil))))
81 82 83
     (let ((newobj (eval (first forms))))
       (eval (subst newobj obj (second forms)))
       (values
sds's avatar
sds committed
84 85 86
        (length forms)
        (eqt (class-of obj) (class-of newobj))
        (map-slot-boundp* newobj '(a b c)))))
87 88 89 90 91
  2 t (nil nil nil))

;;; If :slot-names is missing, all initialized slots are retained
(deftest make-load-form-saving-slots.7
  (let* ((obj (make-instance 'mlfss-02 :a (list 'x) :c 6/5))
sds's avatar
sds committed
92 93
         (forms (multiple-value-list
                 (make-load-form-saving-slots obj))))
94 95 96
     (let ((newobj (eval (first forms))))
       (eval (subst newobj obj (second forms)))
       (values
sds's avatar
sds committed
97 98 99 100
        (length forms)
        (eqt (class-of obj) (class-of newobj))
        (map-slot-boundp* newobj '(a b c))
        (map-slot-value newobj '(a c)))))
101 102 103 104 105
  2 t (t nil t) ((x) 6/5))

;;; If :slot-names is present, all initialized slots in the list are retained
(deftest make-load-form-saving-slots.8
  (let* ((obj (make-instance 'mlfss-02 :a (list 'x) :c 6/5))
sds's avatar
sds committed
106 107
         (forms (multiple-value-list
                 (make-load-form-saving-slots obj :slot-names '(c)))))
108 109 110
     (let ((newobj (eval (first forms))))
       (eval (subst newobj obj (second forms)))
       (values
sds's avatar
sds committed
111 112 113 114
        (length forms)
        (eqt (class-of obj) (class-of newobj))
        (map-slot-boundp* newobj '(a b c))
        (slot-value newobj 'c))))
115 116 117 118 119
  2 t (nil nil t) 6/5)

;; It takes an :environment parameter
(deftest make-load-form-saving-slots.9
  (let* ((obj (make-instance 'mlfss-02 :a 7 :c 64 :b 100))
sds's avatar
sds committed
120 121
         (forms (multiple-value-list
                 (make-load-form-saving-slots obj :environment nil))))
122 123 124
     (let ((newobj (eval (first forms))))
       (eval (subst newobj obj (second forms)))
       (values
sds's avatar
sds committed
125 126 127 128
        (length forms)
        (eqt (class-of obj) (class-of newobj))
        (map-slot-boundp* newobj '(a b c))
        (map-slot-value newobj '(a b c)))))
129 130
  2 t (t t t) (7 100 64))

131
(defpackage "CL-TEST-MLFSS-PACKAGE" (:use) (:export #:a))
132 133 134 135
(defstruct mlfss-03 cl-test-mlfss-package:a)

(deftest make-load-form-savings-slots.10
  (let* ((obj (make-mlfss-03 :a 17))
sds's avatar
sds committed
136 137
         (forms (multiple-value-list
                 (make-load-form-saving-slots obj))))
138 139 140 141 142 143 144 145 146 147 148
    (let ((newobj (eval (first forms))))
      (eval (subst newobj obj (second forms)))
      (values
       (mlfss-03-a obj)
       (length forms)
       (eqt (class-of obj) (class-of newobj))
       (mlfss-03-a newobj))))
  17 2 t 17)

(deftest make-load-form-savings-slots.11
  (let* ((obj (make-mlfss-03 :a 17))
sds's avatar
sds committed
149 150 151 152
         (forms (multiple-value-list
                 (make-load-form-saving-slots
                  obj
                  :slot-names '(cl-test-mlfss-package:a)))))
153 154 155 156 157 158 159 160 161 162 163 164 165 166
    (let ((newobj (eval (first forms))))
      (eval (subst newobj obj (second forms)))
      (values
       (mlfss-03-a obj)
       (length forms)
       (eqt (class-of obj) (class-of newobj))
       (mlfss-03-a newobj))))
  17 2 t 17)


(defstruct mlfss-04 (a 0 :read-only t))

(deftest make-load-form-savings-slots.12
  (let* ((obj (make-mlfss-04 :a 123))
sds's avatar
sds committed
167 168
         (forms (multiple-value-list
                 (make-load-form-saving-slots obj))))
169 170 171 172 173 174 175 176 177
    (let ((newobj (eval (first forms))))
      (eval (subst newobj obj (second forms)))
      (values
       (mlfss-04-a obj)
       (length forms)
       (eqt (class-of obj) (class-of newobj))
       (mlfss-04-a newobj))))
  123 2 t 123)

178 179 180 181

;;; General error tests

(deftest make-load-form-saving-slots.error.1
182 183
  (signals-error (make-load-form-saving-slots) program-error)
  t)
184 185

(deftest make-load-form-saving-slots.error.2
186
  (signals-error (make-load-form-saving-slots (make-instance 'mlfss-02)
sds's avatar
sds committed
187 188
                                               :slot-names)
                 program-error)
189
  t)
190

191
(deftest make-load-form-saving-slots.error.3
192
  (signals-error (make-load-form-saving-slots (make-instance 'mlfss-02)
sds's avatar
sds committed
193 194
                                               (gensym) t)
                 program-error)
195
  t)