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

(in-package "CONDITIONS")

(defvar *shadowed-symbols* 
  '(BREAK ERROR CERROR WARN CHECK-TYPE ASSERT ETYPECASE CTYPECASE ECASE CCASE))

(defun install-symbol (real clcs)
  (unless (get real ':definition-before-clcs)
    (setf (get real ':definition-before-clcs)
	  (symbol-function real)))
  (unless (eq (symbol-function real)
	      (symbol-function clcs))	       
    (setf (symbol-function real)
	  (symbol-function clcs))))

(defun revert-symbol (real)
  (when (and (get real ':definition-before-clcs)
	     (not (eq (symbol-function real)
		      (get real ':definition-before-clcs))))
    (setf (symbol-function real)
	  (get real ':definition-before-clcs))))

(defvar *clcs-redefinitions*
  (nconc (mapcar #'(lambda (symbol)
		     (list (intern (symbol-name symbol) "LISP") symbol))
		 *shadowed-symbols*)
	 '((compile-file clcs-compile-file)
	   (compile clcs-compile)
           (load clcs-load)
           (open clcs-open)
	   #+kcl (si::break-level si::clcs-break-level)
	   #+kcl (si::terminal-interrupt si::clcs-terminal-interrupt)
	   #+kcl (si::break-quit si::clcs-break-quit)
	   #+kcl (si::error-set clcs-error-set)
	   #+kcl (si::universal-error-handler clcs-universal-error-handler))))

(defun install-clcs-symbols ()
  (dolist (r *clcs-redefinitions*)
    (install-symbol (first r) (second r)))
  nil)

(defun revert-clcs-symbols ()
  (dolist (r (reverse *clcs-redefinitions*))
    (revert-symbol (first r)))
  nil)

(defun clcs-compile-file (file &rest args)
  (loop (with-simple-restart (retry "Retry compiling file ~S." file)
	  (let ((values (multiple-value-list 
			    (apply (or (get 'compile-file ':definition-before-clcs)
				       #'compile-file)
				   file args))))
	    (unless #+kcl compiler::*error-p* #-kcl nil
	      (return-from clcs-compile-file
		(values-list values)))
	    (error "~S failed." 'compile-file)))))

(defun clcs-compile (&rest args)
  (loop (with-simple-restart (retry "Retry compiling ~S." (car args))
	  (let ((values (multiple-value-list 
			    (apply (or (get 'compile ':definition-before-clcs)
				       #'compile-file)
				   args))))
	    (unless #+kcl compiler::*error-p* #-kcl nil
	      (return-from clcs-compile
		(values-list values)))
	    (error "~S failed." 'compile)))))

(defun clcs-load (file &rest args)
  (loop (with-simple-restart (retry "Retry loading file ~S." file)
          (return-from clcs-load 
                       (apply (or (get 'load ':definition-before-clcs) #'load)
                              file args)))))

(defun clcs-open (file &rest args)
  (loop (with-simple-restart (retry "Retry opening file ~S." file)
          (return-from clcs-open
                       (apply (or (get 'open ':definition-before-clcs) #'open)
                              file args)))))

#+(or kcl lucid cmu)
(install-clcs-symbols)

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

#+dsys
(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)))))