diff --git a/src/cmp/cmpenv-optimize.lsp b/src/cmp/cmpenv-optimize.lsp
index bf94768da..a586e8186 100644
--- a/src/cmp/cmpenv-optimize.lsp
+++ b/src/cmp/cmpenv-optimize.lsp
@@ -66,74 +66,100 @@
 ;; ERROR CHECKING POLICY
 ;;
 
-(define-policy ext:assume-no-errors :off safety 1)
+(define-policy ext:assume-no-errors
+  "All bets are off."
+  (:off safety 1))
 
-(define-policy ext:assume-right-type :alias ext:assume-no-errors)
+(define-policy-alias ext:assume-right-type
+  "Don't insert optional runtime type checks for known types."
+  (:alias ext:assume-no-errors))
 
-(define-policy ext:type-assertions :anti-alias ext:assume-no-errors
-  "Generate type assertions when inlining accessors and other functions.")
+(define-policy-alias ext:type-assertions
+  "Generate type assertions when inlining accessors and other functions."
+  (:anti-alias ext:assume-no-errors))
 
-(define-policy ext:check-stack-overflow :on safety 2
-  "Add a stack check to every function")
+(define-policy ext:check-stack-overflow
+  "Add a stack check to every function"
+  (:on safety 2))
 
-(define-policy ext:check-arguments-type :on safety 1
-  "Generate CHECK-TYPE forms for function arguments with type declarations")
+(define-policy ext:check-arguments-type
+  "Generate CHECK-TYPE forms for function arguments with type declarations."
+  (:on safety 1))
 
-(define-policy ext:array-bounds-check :on safety 1
-  "Check out of bounds access to arrays")
+(define-policy ext:array-bounds-check
+  "Check out of bounds access to arrays."
+  (:on safety 1))
 
-(define-policy ext:global-var-checking :on safety 3
-  "Read the value of a global variable even if it is discarded, ensuring it is bound")
+(define-policy ext:global-var-checking
+  "Read the value of a global variable even if it is discarded, ensuring it is bound."
+  (:on safety 3))
 
-(define-policy ext:global-function-checking :on safety 3
-  "Read the binding of a global function even if it is discarded")
+(define-policy ext:global-function-checking
+  "Read the binding of a global function even if it is discarded."
+  (:on safety 3))
 
-(define-policy ext:check-nargs :on safety 1 :only-on ext:check-arguments-type 1
-  "Check that the number of arguments a function receives is within bounds")
+(define-policy ext:check-nargs
+  "Check that the number of arguments a function receives is within bounds."
+  (:on safety 1)
+  (:only-on ext:check-arguments-type))
 
-(define-policy ext:the-is-checked :on safety 1
-  "THE is equivalent to EXT:CHECKED-VALUE. Otherwise THE is equivalent to EXT:TRULY-THE.")
+(define-policy ext:the-is-checked
+  "THE is equivalent to EXT:CHECKED-VALUE. Otherwise THE is equivalent to EXT:TRULY-THE."
+  (:on safety 1))
 
 ;;
 ;; INLINING POLICY
 ;;
 
-(define-policy ext:assume-types-dont-change :off safety 1
-  "Assume that type and class definitions will not change")
+(define-policy ext:assume-types-dont-change
+  "Assume that type and class definitions will not change."
+  (:off safety 1))
 
-(define-policy ext:inline-slot-access :on speed 1 :off debug 2 :off safety 2
-  "Inline access to structures and sealed classes")
+(define-policy ext:inline-slot-access
+  "Inline access to structures and sealed classes."
+  (:on speed 1)
+  (:off debug 2)
+  (:off safety 2))
 
-(define-policy ext:inline-accessors :off debug 2 :off space 2
-  "Inline access to object slots, including conses and arrays")
+(define-policy ext:inline-accessors
+  "Inline access to object slots, including conses and arrays."
+  (:off debug 2)
+  (:off space 2))
 
-(define-policy ext:inline-bit-operations :off space 2
-  "Inline LDB and similar functions")
+(define-policy ext:inline-bit-operations
+  "Inline LDB and similar functions."
+  (:off space 2))
 
-(define-policy ext:open-code-aref/aset :alias ext:inline-accessors
-  "Inline access to arrays")
+(define-policy-alias ext:open-code-aref/aset
+  "Inline access to arrays."
+  (:alias ext:inline-accessors))
 
-(define-policy ext:evaluate-forms :off debug 1
-  "Pre-evaluate a function that takes constant arguments")
+(define-policy ext:evaluate-forms
+  "Pre-evaluate a function that takes constant arguments."
+  (:off debug 1))
 
-(define-policy ext:use-direct-C-call :off debug 2
-  "Emit direct calls to a function whose C name is known")
+(define-policy ext:use-direct-C-call
+  "Emit direct calls to a function whose C name is known."
+  (:off debug 2))
 
-(define-policy ext:inline-type-checks :off space 2
-  "Expand TYPEP and similar forms in terms of simpler functions, such as FLOATP,
-INTGERP, STRINGP.")
+(define-policy ext:inline-type-checks
+  "Expand TYPEP and similar forms in terms of simpler functions, such as FLOATP, INTGERP, STRINGP."
+  (:off space 2))
 
-(define-policy ext:inline-sequence-functions :off space 2
-  "Inline functions such as MAP, MEMBER, FIND, etc")
+(define-policy ext:inline-sequence-functions
+  "Inline functions such as MAP, MEMBER, FIND, etc."
+  (:off space 2))
 
 ;;
 ;; DEBUG POLICY
 ;;
 
-(define-policy ext:debug-variable-bindings :on debug 3
-  :requires (policy-debug-ihs-frame env)
+(define-policy ext:debug-variable-bindings
+  "Create a debug vector with the bindings of each LET/LET*/LAMBDA form."
   ;; We can only create variable bindings when the function has an IHS frame!!!
-  "Create a debug vector with the bindings of each LET/LET*/LAMBDA form?")
+  (:requires (policy-debug-ihs-frame env))
+  (:on debug 3))
 
-(define-policy ext:debug-ihs-frame :on debug 3
-  "Let the functions appear in backtraces")
+(define-policy ext:debug-ihs-frame
+  "Let the functions appear in backtraces."
+  (:on debug 3))
diff --git a/src/cmp/cmppolicy.lsp b/src/cmp/cmppolicy.lsp
index c1b5435d0..e0d0a438a 100644
--- a/src/cmp/cmppolicy.lsp
+++ b/src/cmp/cmppolicy.lsp
@@ -14,13 +14,15 @@
 
 (in-package "COMPILER")
 
+
 (defconstant *standard-optimization-quality-names*
   '(debug safety speed space compilation-speed))
 
 (eval-when (:compile-toplevel :execute)
+  (defvar *last-optimization-bit* 20)
   (defvar *optimization-quality-switches*
     (loop with hash = (make-hash-table :size 64 :test #'eq)
-          for name in '(debug safety speed space compilation-speed)
+          for name in *standard-optimization-quality-names*
           for i from 0 by 4
           for list = (loop with mask = (ash #b1111 i)
                            for level from 0 to 3
@@ -28,12 +30,17 @@
                            collect (cons bits (logxor bits mask)))
           do (setf (gethash name hash) list)
           finally (return hash)))
-  (defvar *last-optimization-bit* 20)
-  (defvar *optimization-bits* (make-hash-table)))
+  ;; For the standard qualities we encode the lowest bit position.
+  (defvar *optimization-bits*
+    (loop with hash = (make-hash-table :size 64 :test #'eq)
+          for name in *standard-optimization-quality-names*
+          for i from 0 by 4
+          do (setf (gethash name hash) i)
+          finally (return hash))))
 
 (eval-when (:load-toplevel :execute)
-  (defvar *optimization-quality-switches* #.*optimization-quality-switches*)
   (defvar *last-optimization-bit* #.*last-optimization-bit*)
+  (defvar *optimization-quality-switches* #.*optimization-quality-switches*)
   (defvar *optimization-bits* #.*optimization-bits*))
 
 (defun take-optimization-bit (name)
@@ -44,103 +51,92 @@
 (defun optimization-quality-switches (type index)
   (nth index (gethash type *optimization-quality-switches*)))
 
-(defun compute-policy (arguments old-bits)
-  (let* ((bits old-bits)
-         (on 0)
-         (off 0))
+(defun compute-policy (arguments old-bits &aux (on 0) (off 0))
+  (flet ((get-flags (x)
+           (if (atom x)
+               (optimization-quality-switches x 3)
+               (destructuring-bind (name value) x
+                 (when (typep value '(integer 0 3))
+                   (optimization-quality-switches name value))))))
     (dolist (x arguments)
-      (let (flags name value)
-        (cond ((symbolp x)
-               (setq name x
-                     value 3
-                     flags (optimization-quality-switches name value)))
-              ((or (not (consp x))
-                   (not (consp (cdr x)))
-                   (not (numberp (second x)))
-                   (not (<= 0 (second x) 3))))
-              (t
-               (setf name (first x)
-                     value (second x)
-                     flags (optimization-quality-switches name value))))
-        (if (null flags)
-            (cmpwarn "Illegal or unknown OPTIMIZE proclamation ~s." x)
-            (setf on (logior on (car flags))
-                  off (logior off (cdr flags))))))
-    ;;(format t "~%*~64b" bits)
-    ;;(format t "~% ~64b" on)
-    ;;(format t "~% ~64b" off)
-    (logandc2 (logior bits on) off)))
+      (ext:if-let ((flags (get-flags x)))
+        (setf on  (logior on  (car flags))
+              off (logior off (cdr flags)))
+        (cmpwarn "Illegal or unknown OPTIMIZE proclamation ~s." x))))
+  (logandc2 (logior old-bits on) off))
 
 ;;; for example        debug   2     :on    #x10
 (defun augment-policy (quality level on-off flag)
-  (loop for i from 0 to 3
-        for bits = (optimization-quality-switches quality i)
-        do (if (< i level)
-               (case on-off
-                 (:on (rplacd bits (logior (cdr bits) flag)))
-                 (:off (rplaca bits (logior (car bits) flag))))
-               (case on-off
-                 ((:only-on :on) (rplaca bits (logior (car bits) flag)))
-                 ((:only-off :off) (rplacd bits (logior (cdr bits) flag)))))))
+  (flet ((flip (on-off switches flag)
+           (ecase on-off
+             (:on  (rplaca switches (logior (car switches) flag)))
+             (:off (rplacd switches (logior (cdr switches) flag))))))
+    (loop for i from 0 to 3
+          for bits = (optimization-quality-switches quality i)
+          do (if (< i level)
+                 (ecase on-off
+                   (:on       (flip :off bits flag))
+                   (:off      (flip :on  bits flag))
+                   (:only-on  nil)
+                   (:only-off nil))
+                 (ecase on-off
+                   (:on       (flip :on  bits flag))
+                   (:off      (flip :off bits flag))
+                   (:only-on  (flip :on  bits flag))
+                   (:only-off (flip :off bits flag)))))))
 
 (defun policy-function-name (base)
   (intern (concatenate 'string "POLICY-" (symbol-name base))
           (find-package "C")))
 
 (defmacro define-policy (&whole whole name &rest conditions)
-  (let* ((test (ash 1 (take-optimization-bit name)))
-         (function-name (policy-function-name name))
-         (doc (find-if #'stringp conditions))
-         (emit-function t))
-    ;; If it is an alias, just copy the bits
-    ;; Register as an optimization quality with its own flags
+  (let ((doc (and (stringp (car conditions)) (pop conditions)))
+        (test (ash 1 (take-optimization-bit name)))
+        (function-name (policy-function-name name)))
+    ;; Register as an optimization quality with its own flags.
     (let* ((circular-list (list (cons test 0)))
            (flags-list (list* (cons 0 test) circular-list)))
       (rplacd circular-list circular-list)
       (setf (gethash name *optimization-quality-switches*) flags-list))
-    ;; Scan the definition and correct the flags
+    ;; Scan the definition and propagate flags of dependent policies.
     (loop with extra = '()
-          with conditions = (remove doc conditions)
-          for case = (pop conditions)
-          while case
-          do (case case
-               (:no-function
-                (setf emit-function nil))
-               (:alias
-                (let* ((alias (first conditions)))
-                  (setf (gethash name  *optimization-quality-switches*)
-                        (gethash alias *optimization-quality-switches*))
-                  (return `(defun ,function-name (&optional (env *cmp-env*))
-                             ,@(and doc (list doc))
-                             (,(policy-function-name alias) env)))))
-               (:anti-alias
-                (let* ((alias (first conditions))
-                       (bits (gethash alias *optimization-quality-switches*)))
-
-                  (setf bits (list (second bits)
-                                   (first bits)))
-                  (rplacd (cdr bits) (cdr bits))
-                  (setf (gethash name *optimization-quality-switches*) bits)
-                  (return `(defun ,function-name (&optional (env *cmp-env*))
-                             ,@(and doc (list doc))
-                             (not (,(policy-function-name alias) env))))))
-               ((:only-on :on)
-                (augment-policy (pop conditions) (pop conditions) case test))
-               ((:only-off :off)
-                (augment-policy (pop conditions) (pop conditions) case test))
+          for case in conditions
+          do (case (car case)
+               ((:on :off)
+                (destructuring-bind (op quality level) case
+                  (augment-policy quality level op test)))
+               ((:only-on :only-off)
+                (destructuring-bind (op quality) case
+                  (augment-policy quality 1 op test)))
                (:requires
-                (push (pop conditions) extra))
+                (destructuring-bind (op form) case
+                  (declare (ignore op))
+                  (push form extra)))
                (otherwise
-                (error "Syntax error in macro~%  ~A"
-                       `(define-policy ,@whole))))
+                (error "Syntax error in macro~%  ~A" `(define-policy ,@whole))))
           finally
              (return
-               (and emit-function
-                    `(defun ,function-name (&optional (env *cmp-env*))
-                       ,@(and doc (list doc))
-                       (let ((bits (cmp-env-policy env)))
-                         (and (logtest bits ,test)
-                              ,@extra))))))))
+               `(defun ,function-name (&optional (env *cmp-env*))
+                  ,@(and doc (list doc))
+                  (let ((bits (cmp-env-policy env)))
+                    (and (logtest bits ,test)
+                         ,@extra)))))))
+
+(defmacro define-policy-alias (name doc (op alias))
+  (let ((bits (gethash alias *optimization-quality-switches*)))
+    (ecase op
+      (:alias
+       (setf (gethash name *optimization-quality-switches*) bits)
+       `(defun ,(policy-function-name name) (&optional (env *cmp-env*))
+          ,doc
+          (,(policy-function-name alias) env)))
+      (:anti-alias
+       (rotatef (first bits) (second bits))
+       (rplacd (cdr bits) (cdr bits))
+       (setf (gethash name *optimization-quality-switches*) bits)
+       `(defun ,(policy-function-name name) (&optional (env *cmp-env*))
+          ,doc
+          (not (,(policy-function-name alias) env)))))))
 
 (macrolet ((define-function (fun-name offset)
              `(defun ,fun-name (policy)