-;;; defaulted from COOKIE.
-(declaim (ftype (function (list cookie) cookie) process-optimize-declaration))
-(defun process-optimize-declaration (spec cookie)
- (let ((res (copy-cookie cookie)))
- (dolist (quality (cdr spec))
- (let ((quality (if (atom quality) (list quality 3) quality)))
- (if (and (consp (cdr quality)) (null (cddr quality))
- (typep (second quality) 'real) (<= 0 (second quality) 3))
- (let ((value (rational (second quality))))
- (case (first quality)
- (speed (setf (cookie-speed res) value))
- (space (setf (cookie-space res) value))
- (safety (setf (cookie-safety res) value))
- (compilation-speed (setf (cookie-cspeed res) value))
- ;; FIXME: BREVITY is an undocumented name for it,
- ;; should go away. And INHIBIT-WARNINGS is a
- ;; misleading name for it. Perhaps BREVITY would be
- ;; better. But the ideal name would have connotations
- ;; of suppressing only optimization-related notes,
- ;; which I think is the behavior. Perhaps
- ;; INHIBIT-NOTES?
- ((inhibit-warnings brevity) (setf (cookie-brevity res) value))
- ((debug-info debug) (setf (cookie-debug res) value))
- (t
- (compiler-warning "unknown optimization quality ~S in ~S"
- (car quality) spec))))
- (compiler-warning
- "malformed optimization quality specifier ~S in ~S"
- quality spec))))
- res))
+;;; defaulted from the POLICY argument.
+(declaim (ftype (function (list policy) policy) process-optimize-decl))
+(defun process-optimize-decl (spec policy)
+ (let ((result nil))
+ ;; Add new entries from SPEC.
+ (dolist (q-and-v-or-just-q (cdr spec))
+ (multiple-value-bind (quality raw-value)
+ (if (atom q-and-v-or-just-q)
+ (values q-and-v-or-just-q 3)
+ (destructuring-bind (quality raw-value) q-and-v-or-just-q
+ (values quality raw-value)))
+ (cond ((not (policy-quality-name-p quality))
+ (or (policy-quality-deprecation-warning quality)
+ (compiler-warn
+ "~@<Ignoring unknown optimization quality ~S in:~_ ~S~:>"
+ quality spec)))
+ ((not (typep raw-value 'policy-quality))
+ (compiler-warn "~@<Ignoring bad optimization value ~S in:~_ ~S~:>"
+ raw-value spec))
+ (t
+ ;; we can't do this yet, because CLOS macros expand
+ ;; into code containing INHIBIT-WARNINGS.
+ #+nil
+ (when (eql quality 'sb!ext:inhibit-warnings)
+ (compiler-style-warn "~S is deprecated: use ~S instead"
+ quality 'sb!ext:muffle-conditions))
+ (push (cons quality raw-value)
+ result)))))
+ ;; Add any nonredundant entries from old POLICY.
+ (dolist (old-entry policy)
+ (unless (assq (car old-entry) result)
+ (push old-entry result)))
+ ;; Voila.
+ (sort-policy result)))
+
+(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))