/[gcl]/gcl/ansi-tests/define-condition.lsp
ViewVC logotype

Diff of /gcl/ansi-tests/define-condition.lsp

Parent Directory Parent Directory | Revision Log Revision Log | View Patch Patch

revision 1.4 by pfdietz, Sat Mar 15 19:21:13 2003 UTC revision 1.5 by pfdietz, Wed Mar 19 04:25:27 2003 UTC
# Line 306  Line 306 
306          (c (make-condition 'cond-18 :i1 4321)))          (c (make-condition 'cond-18 :i1 4321)))
307      (with-output-to-string (s) (print-object c s)))      (with-output-to-string (s) (print-object c s)))
308    "cond-18: 4321")    "cond-18: 4321")
309    
310    ;;;
311    ;;; Tests of :default-initargs
312    ;;;
313    ;;; There is an inconsistency in the ANSI spec.  DEFINE-CONDITION
314    ;;; says that in (:default-initargs . <foo>), <foo> is a list of pairs.
315    ;;; However, DEFCLASS says it's a list whose alternate elements
316    ;;; are initargs and initforms.  I have taken the second interpretation.
317    ;;;
318    
319    (define-condition-with-tests cond-19 nil
320      ((s1 :reader cond-19/s1 :initarg :i1)
321       (s2 :reader cond-19/s2 :initarg :i2))
322      (:default-initargs :i1 10
323                         :i2 20))
324    
325    (deftest cond-19-slots.1
326      (let ((c (make-condition 'cond-19)))
327        (values
328         (notnot (typep c 'cond-19))
329         (cond-19/s1 c)
330         (cond-19/s2 c)))
331      t 10 20)
332    
333    (deftest cond-19-slots.2
334      (let ((c (make-condition 'cond-19 :i1 'a)))
335        (values
336         (notnot (typep c 'cond-19))
337         (cond-19/s1 c)
338         (cond-19/s2 c)))
339      t a 20)
340    
341    (deftest cond-19-slots.3
342      (let ((c (make-condition 'cond-19 :i2 'a)))
343        (values
344         (notnot (typep c 'cond-19))
345         (cond-19/s1 c)
346         (cond-19/s2 c)))
347      t 10 a)
348    
349    (deftest cond-19-slots.4
350      (let ((c (make-condition 'cond-19 :i1 'x :i2 'y)))
351        (values
352         (notnot (typep c 'cond-19))
353         (cond-19/s1 c)
354         (cond-19/s2 c)))
355      t x y)
356    
357    (deftest cond-19-slots.5
358      (let ((c (make-condition 'cond-19 :i2 'y :i1 'x)))
359        (values
360         (notnot (typep c 'cond-19))
361         (cond-19/s1 c)
362         (cond-19/s2 c)))
363      t x y)
364    
365    (defparameter *cond-20/s1-val* 0)
366    (defparameter *cond-20/s2-val* 0)
367    
368    (define-condition-with-tests cond-20 nil
369      ((s1 :reader cond-20/s1 :initarg :i1)
370       (s2 :reader cond-20/s2 :initarg :i2))
371      (:default-initargs :i1 (incf *cond-20/s1-val*)
372                         :i2 (incf *cond-20/s2-val*)))
373    
374    (deftest cond-20-slots.1
375      (let ((*cond-20/s1-val* 0)
376            (*cond-20/s2-val* 10))
377        (declare (special *cond-20/s1-val* *cond-20/s2-val*))
378        (let ((c (make-condition 'cond-20)))
379          (values
380           (notnot (typep c 'cond-20))
381           (cond-20/s1 c)
382           (cond-20/s2 c)
383           *cond-20/s1-val*
384           *cond-20/s2-val*)))
385      t 1 11 1 11)
386    
387    (deftest cond-20-slots.2
388      (let ((*cond-20/s1-val* 0)
389            (*cond-20/s2-val* 10))
390        (declare (special *cond-20/s1-val* *cond-20/s2-val*))
391        (let ((c (make-condition 'cond-20 :i1 'x)))
392          (values
393           (notnot (typep c 'cond-20))
394           (cond-20/s1 c)
395           (cond-20/s2 c)
396           *cond-20/s1-val*
397           *cond-20/s2-val*)))
398      t x 11 0 11)
399    
400    (deftest cond-20-slots.3
401      (let ((*cond-20/s1-val* 0)
402            (*cond-20/s2-val* 10))
403        (declare (special *cond-20/s1-val* *cond-20/s2-val*))
404        (let ((c (make-condition 'cond-20 :i2 'y)))
405          (values
406           (notnot (typep c 'cond-20))
407           (cond-20/s1 c)
408           (cond-20/s2 c)
409           *cond-20/s1-val*
410           *cond-20/s2-val*)))
411      t 1 y 1 10)
412    
413    (deftest cond-20-slots.4
414      (let ((*cond-20/s1-val* 0)
415            (*cond-20/s2-val* 10))
416        (declare (special *cond-20/s1-val* *cond-20/s2-val*))
417        (let ((c (make-condition 'cond-20 :i2 'y :i1 'x)))
418          (values
419           (notnot (typep c 'cond-20))
420           (cond-20/s1 c)
421           (cond-20/s2 c)
422           *cond-20/s1-val*
423           *cond-20/s2-val*)))
424      t x y 0 10)
425    
426    
427    ;;;;;;;;; tests of inheritance
428    
429    (define-condition-with-tests cond-21 (cond-4) nil)
430    
431    (deftest cond-21-slots.1
432      (let ((c (make-condition 'cond-21 :slot1 'a :slot2 'b)))
433        (and (typep c 'cond-4)
434             (typep c 'cond-21)
435             (eqt (cond-4/slot-1 c) 'a)
436             (eqt (cond-4/slot-2 c) 'b)))
437      t)
438    
439    (define-condition-with-tests cond-22 (cond-4)
440      ((slot3 :initarg :slot3 :reader cond-22/slot-3)
441       (slot4 :initarg :slot4 :reader cond-22/slot-4)))
442    
443    (deftest cond-22-slots.1
444      (let ((c (make-condition 'cond-22 :slot1 'a :slot2 'b
445                               :slot3 'c :slot4 'd)))
446        (and (typep c 'cond-4)
447             (typep c 'cond-22)
448             (eqt (cond-4/slot-1 c) 'a)
449             (eqt (cond-4/slot-2 c) 'b)
450             (eqt (cond-22/slot-3 c) 'c)
451             (eqt (cond-22/slot-4 c) 'd)
452             ))
453      t)
454    
455    (define-condition-with-tests cond-23 (cond-5) nil)
456    
457    (deftest cond-23-slots.1
458      (let ((c (make-condition 'cond-23 :slot1 'a :slot2 'b)))
459        (and (typep c 'cond-5)
460             (typep c 'cond-23)
461             (eqt (cond-4/slot-1 c) 'a)
462             (eqt (cond-4/slot-2 c) 'b)
463             ))
464      t)
465    
466    (deftest cond-23-slots.2
467      (let ((c (make-condition 'cond-23 :slot1 'a)))
468        (and (typep c 'cond-5)
469             (typep c 'cond-23)
470             (eqt (cond-4/slot-1 c) 'a)
471             (eqt (cond-4/slot-2 c) 'y)
472             ))
473      t)
474    
475    (deftest cond-23-slots.3
476      (let ((c (make-condition 'cond-23 :slot2 'b)))
477        (and (typep c 'cond-5)
478             (typep c 'cond-23)
479             (eqt (cond-4/slot-1 c) 'x)
480             (eqt (cond-4/slot-2 c) 'b)
481             ))
482      t)
483    
484    (deftest cond-23-slots.4
485      (let ((c (make-condition 'cond-23)))
486        (and (typep c 'cond-5)
487             (typep c 'cond-23)
488             (eqt (cond-4/slot-1 c) 'x)
489             (eqt (cond-4/slot-2 c) 'y)
490             ))
491      t)
492    
493    
494    
495    

Legend:
Removed from v.1.4  
changed lines
  Added in v.1.5

savannah-hackers-public@gnu.org
ViewVC Help
Powered by ViewVC 1.1.26