Commit 35b12e67 authored by pfdietz's avatar pfdietz

Added ignore-error forms in change-class.lsp to get gcl to not bomb out on...

Added ignore-error forms in change-class.lsp to get gcl to not bomb out on loading.  Added order of evaluation tests for slot-boundp, slot-exists-p, slot-makunbound and slot-value.
parent 9ee72639
......@@ -376,13 +376,14 @@
(defclass change-class-class-05 ()
(a b c))
(defmethod change-class
((obj change-class-class-05)
(new-class (eql (find-class 'change-class-class-05)))
&rest initargs &key &allow-other-keys)
(declare (ignore initargs new-class))
(setq *changed-class-on-class-05* t)
obj)
(ignore-errors
(defmethod change-class
((obj change-class-class-05)
(new-class (eql (find-class 'change-class-class-05)))
&rest initargs &key &allow-other-keys)
(declare (ignore initargs new-class))
(setq *changed-class-on-class-05* t)
obj))
(deftest change-class.5
(let ((*changed-class-on-class-05* nil)
......@@ -397,13 +398,14 @@
(defclass change-class-class-06 ()
((a :initarg :a) (b :initarg :b) (c :initarg :c)))
(defmethod change-class
((obj change-class-class-06)
(new-class standard-class)
&rest initargs &key &allow-other-keys)
(declare (ignore initargs))
(setf (slot-value obj 'a) 123)
(call-next-method))
(ignore-errors
(defmethod change-class
((obj change-class-class-06)
(new-class standard-class)
&rest initargs &key &allow-other-keys)
(declare (ignore initargs))
(setf (slot-value obj 'a) 123)
(call-next-method)))
(deftest change-class.6.1
(let* ((class (find-class 'change-class-class-06))
......@@ -444,14 +446,15 @@
((a :initform 'aa :initarg :a)
(d :initform 'dd :initarg :d)))
(defmethod change-class :before
((obj change-class-class-07)
(new-class standard-class)
&rest initargs &key &allow-other-keys)
(declare (ignore initargs))
(setf (slot-value obj 'a) 'z)
obj)
(ignore-errors
(defmethod change-class :before
((obj change-class-class-07)
(new-class standard-class)
&rest initargs &key &allow-other-keys)
(declare (ignore initargs))
(setf (slot-value obj 'a) 'z)
obj))
(deftest change-class.7.1
(let* ((class (find-class 'change-class-class-07))
(obj (allocate-instance class)))
......@@ -530,13 +533,14 @@
(defclass change-class-class-08 () ((a :initarg :a) (b :initarg :b)))
(defmethod change-class :after
((obj standard-object)
(class (eql (find-class 'change-class-class-08)))
&rest initargs &key &allow-other-keys)
(declare (ignore initargs))
(setf (slot-value obj 'a) 'z)
obj)
(ignore-errors
(defmethod change-class :after
((obj standard-object)
(class (eql (find-class 'change-class-class-08)))
&rest initargs &key &allow-other-keys)
(declare (ignore initargs))
(setf (slot-value obj 'a) 'z)
obj))
(deftest change-class.8.1
(let* ((class (find-class 'change-class-class-08))
......
......@@ -37,6 +37,17 @@
(slot-boundp obj 'c))
nil)
;;; Argument order test(s)
(deftest slot-boundp.order.1
(let ((obj (make-instance 'slot-boundp-class-01))
(i 0) x y)
(values
(slot-boundp (progn (setf x (incf i)) obj)
(progn (setf y (incf i)) 'a))
i x y))
nil 2 1 2)
;;; Error tests
(deftest slot-boundp.error.1
......
......@@ -117,7 +117,7 @@
;;; (after all, they are objects, and they have slots)
(define-condition slot-exists-p-condition-01 ()
(a b c))
((a) (b) (c)))
(deftest slot-exists-p.15
(let ((obj (make-condition 'slot-exists-p-condition-01)))
......@@ -125,13 +125,40 @@
(t t t nil))
(define-condition slot-exists-p-condition-02 (slot-exists-p-condition-01)
(a d e))
((a) (d) (e)))
(deftest slot-exists-p.16
(let ((obj (make-condition 'slot-exists-p-condition-02)))
(map-slot-exists-p* obj (list 'a 'b 'c 'd 'e (gensym))))
(t t t t t nil))
;;; Order of evaluation tests
(deftest slot-exists-p.order.1
(let ((i 0) x y)
(values
(slot-exists-p (progn (setf x (incf i)) 'a)
(progn (setf y (incf i)) (gensym)))
i x y))
nil 2 1 2)
(deftest slot-exists-p.order.2
(let ((obj (allocate-instance (find-class 'slot-exists-p-class-01)))
(i 0) x y)
(values
(notnot (slot-exists-p (progn (setf x (incf i)) obj)
(progn (setf y (incf i)) 'a)))
i x y))
t 2 1 2)
(deftest slot-exists-p.order.3
(let ((obj (allocate-instance (find-class 'slot-exists-p-class-01)))
(i 0) x y)
(values
(notnot (slot-exists-p (progn (setf x (incf i)) obj)
(progn (setf y (incf i)) 'b)))
i x y))
t 2 1 2)
;;; Errors tests
......
......@@ -39,7 +39,28 @@
collect slot-name)
nil)
;;; Order of evaluation test(s)
(deftest slot-makunbound.order.1
(let ((obj (make-instance 'slot-makunbound-class-01))
(i 0) x y)
(values
(eqt (slot-makunbound (progn (setf x (incf i)) obj)
(progn (setf y (incf i)) 'a))
obj)
i x y))
t 2 1 2)
(deftest slot-makunbound.order.2
(let ((obj (make-instance 'slot-makunbound-class-01))
(i 0) x y)
(setf (slot-value obj 'a) t)
(values
(eqt (slot-makunbound (progn (setf x (incf i)) obj)
(progn (setf y (incf i)) 'a))
obj)
i x y))
t 2 1 2)
;;; Error cases
......
......@@ -79,6 +79,28 @@
collect name))
nil)
;;; Order of evaluation test(s)
(deftest slot-value.order.1
(let ((obj (make-instance 'slot-value-class-01))
(i 0) x y)
(values
(setf (slot-value obj 'a) t)
(slot-value (progn (setf x (incf i)) obj)
(progn (setf y (incf i)) 'a))
i x y))
t t 2 1 2)
(deftest slot-value.order.2
(let ((obj (make-instance 'slot-value-class-01))
(i 0) x y)
(values
(setf (slot-value (progn (setf x (incf i)) obj)
(progn (setf y (incf i)) 'b))
t)
(slot-value obj 'b)
i x y))
t t 2 1 2)
;;; Error tests
......
Markdown is supported
0% or
You are about to add 0 people to the discussion. Proceed with caution.
Finish editing this message first!
Please register or to comment