
(in-package "SI")
(or (fboundp 'desetq)
    (load "/home/wfs/gcl-1.0/lsp/desetq.lsp")
    )

(defmacro with-simple-restart ((restart-name format-control
                                                   &rest format-arguments)
                                     &body forms)
        `(restart-case (progn ,@forms)
           (,restart-name ()
               :report (lambda (stream)
                         (format stream ,format-control ,@format-arguments))
              (values nil t))))


(defvar *restart-bindings* nil)

(defun simple-get-key-args (l1 args &optional defaults)
  (let ((ans (if defaults (copy-list defaults)
	       (make-list (length args))))
	(found (copy-list ans)))
    (loop for (key val) on l1 by 'cddr
	  when (setq n (position key args))
	  do 
	  (if (nth n found) (error "duplicate arg ~s" key)
	    (setf (nth n found) t))
	  (setf (nth n ans) val)
	  else do (error "Incorrect keyword arg ~s" key))
    ans))
	

(eval-when (compile)
(defmacro get-restart (x y)
  `(nth ,(position x '(:name :function
			     :interactive-function
			     :report-function
			     :test-function))
	,y)))

(defmacro restart-bind (bindings &body forms &aux ans)
  (setq ans
	`(let ((*restart-bindings*
		(cons 
		 (loop for v in bindings
		       collect (list*
				(car v)
				(cadr v)
				(simple-get-key-args (cddr v)
						     '(:test-function
						       :interactive-function
						       :report-function
						       ))
				into tem))
		 *restart-bindings*)))
	   ,@forms)))

(defmacro restart-case (restartable-form &rest clauses )
  (let ((bl '#:bl) ans)
    `(block ,bl
	 (restart-bind
	  ,(loop for v in clauses with it
		 do
		 (desetq (name ll ) v)
		 (setq v (cddr v))
		 (let ((defaults (list 
				  '(lambda (c) (declare
						 (ignore c)) t)
				   
				  '(lambda () nil)
				  `(lambda (stream)
				    (write-string
				     ,(format nil
					       "Use restart ~s"
					       name)
				     stream))))
		       (keys '(:test :interactive
				     :report)))
		       
		       (loop with key with val with bod
			do (desetq (key) v) 
			while (member key keys)
			do (desetq (val . bod) v)
			collect key into tem
			collect val into tem
			do (setq v bod)
		       finally
		       (setq ans
			     (simple-get-key-args tem keys defaults)))
		       (let ((report (last ans)))
			 (if (stringp (car report))
			     (setf (car report)
				   `(lambda (stream)
				     (write-string ,(car report) stream)) )))
		       (loop for v on ans with x
			     do (setq x (car v))
			     (cond ((null x))
				   ((or (symbolp x)
					(and (consp x) (eq (car x) 'lambda)))
				    (setf (car v) `(function ,(car v))))
				   (t (error
				       "~a should be a suitable arg to function" (car v)))))

		       
		    collect
		    (list* name
			   `(function (lambda) ,ll
				      (return-from ,bl
						   (progn ,@v)))
			   ans)))
	     ,restartable-form))))

	     
	     
			  
				     
		    

		       

			       
  
	
	
	
	
	


