+(declaim (ftype (function (list list) list)
+ process-handle-conditions-decl))
+(defun process-handle-conditions-decl (spec list)
+ (let ((new (copy-alist list)))
+ (dolist (clause (cdr spec))
+ (destructuring-bind (typespec restart-name) clause
+ (let ((ospec (rassoc restart-name new :test #'eq)))
+ (if ospec
+ (setf (car ospec)
+ (type-specifier
+ (type-union (specifier-type (car ospec))
+ (specifier-type typespec))))
+ (push (cons (type-specifier (specifier-type typespec))
+ restart-name)
+ new)))))
+ new))
+(declaim (ftype (function (list list) list)
+ process-muffle-conditions-decl))
+(defun process-muffle-conditions-decl (spec list)
+ (process-handle-conditions-decl
+ (cons 'handle-conditions
+ (mapcar (lambda (x) (list x 'muffle-warning)) (cdr spec)))
+ list))
+
+(declaim (ftype (function (list list) list)
+ process-unhandle-conditions-decl))
+(defun process-unhandle-conditions-decl (spec list)
+ (let ((new (copy-alist list)))
+ (dolist (clause (cdr spec))
+ (destructuring-bind (typespec restart-name) clause
+ (let ((ospec (rassoc restart-name new :test #'eq)))
+ (if ospec
+ (let ((type-specifier
+ (type-specifier
+ (type-intersection
+ (specifier-type (car ospec))
+ (specifier-type `(not ,typespec))))))
+ (if type-specifier
+ (setf (car ospec) type-specifier)
+ (setq new
+ (delete restart-name new :test #'eq :key #'cdr))))
+ ;; do nothing?
+ nil))))
+ new))
+(declaim (ftype (function (list list) list)
+ process-unmuffle-conditions-decl))
+(defun process-unmuffle-conditions-decl (spec list)
+ (process-unhandle-conditions-decl
+ (cons 'unhandle-conditions
+ (mapcar (lambda (x) (list x 'muffle-warning)) (cdr spec)))
+ list))
+