;;; -*- Mode: Lisp; Syntax: Common-Lisp; Package: "CONDITIONS"; Base: 10 -*-

(in-package "CONDITIONS" :USE '("LISP" #+(and clos (not pcl)) "CLOS" #+pcl "PCL"))

#-(or lucid excl genera)
(progn

#+pcl
(eval-when (compile load eval)
(defun exercise-condition-classes ()
  (let ((gfuns nil))
    (dolist (name '(make-instance
		    initialize-instance
		    shared-initialize
		    print-object))
      (push (pcl::gdefinition name) gfuns))
    (labels ((do-class (class)
	       (dolist (gfun (pcl::specializer-generic-functions class))
		 (pushnew gfun gfuns))
	       (dolist (dsub (pcl::class-direct-subclasses class))
		 (do-class dsub))))
      (do-class (find-class 'condition)))
    (mapc #'pcl::exercise-generic-function gfuns))
  nil)
)

#+pcl
(progn
(eval-when (compile)
(exercise-condition-classes)
)

(pcl::precompile-random-code-segments clcs)

(eval-when (load eval)
(exercise-condition-classes)
)
)

#+kcl (install-clcs-symbols)

)

(defun dsys::retry-operation (function retry-string)
  (loop (with-simple-restart (retry retry-string)
	  (return-from dsys::retry-operation
	    (funcall function)))))

(defun dsys::operate-on-module (module initial-state system-operation)
  (if (null dsys::*retry-operation-list*)
      (dsys::operate-on-module1 module initial-state system-operation)
      (let ((retry-operation (car (last dsys::*retry-operation-list*)))
	    (dsys::*retry-operation-list* (butlast dsys::*retry-operation-list*)))
	(restart-bind ((retry 
			#'(lambda (&rest ignore)
			    (declare (ignore ignore))
			    (funcall (car retry-operation)))
			:report-function
			#'(lambda (stream)
			    (write-string (cdr retry-operation) stream))))
	   (dsys::operate-on-module module initial-state system-operation)))))