diff --git a/MANUAL.md b/MANUAL.md
index e548568..4b6e821 100644
--- a/MANUAL.md
+++ b/MANUAL.md
@@ -21,6 +21,22 @@ Parses a type specifier to a ctype in the given environment. The default environ
 
 ---
 
+[Function]
+
+**extended-specifier-ctype** *type-specifier* `&optional` *environment* => *ctype*
+
+Parses a type specifier to a ctype in the given environment. Parts of the type-specifier might be using extended types. The default environment is `nil`, representing the current global environment. The environment is used to get information about type macros defined with `deftype`.
+
+---
+
+[Macro]
+
+**define-extended-type** *name* *lambda-list* `&key` *documentation* *simple* *extended* => *name*
+
+Defines an extended type specifier called name. If it is parsed using `specifier-ctype` or some other non-extended parsing facility, the simple forms are used to create a more primitive type specifier. If it is parsed using `extended-type-specifier`, the extended forms are used to create a ctype.  Both the simple and extended forms are required.
+
+---
+
 # Relations
 
 ## Definitions
diff --git a/README.md b/README.md
index b8d76aa..932765f 100644
--- a/README.md
+++ b/README.md
@@ -70,4 +70,4 @@ While ctype implements the Common Lisp type system, some users may be interested
 
 The ext/ directory contains a few example extensions. See the README in that directory for more information.
 
-Extension mechanisms for the type specifier parser have not been solidly defined yet.
+Custom ctypes can be represented as type specifiers using `define-extended-type` and accessed using `extended-specifier-ctype` . See the documentation strings for more information.
diff --git a/cmember.lisp b/cmember.lisp
index 2656487..078735a 100644
--- a/cmember.lisp
+++ b/cmember.lisp
@@ -10,21 +10,13 @@
 (defmethod subctypep ((ct1 cmember) (ct2 cmember))
   (values (subsetp (cmember-members ct1) (cmember-members ct2)) t))
 
-(declaim (inline member-disjointp))
-(defun member-disjointp (cmember ctype)
+(define-commutative-method disjointp ((cmember cmember) (ctype ctype))
   (values
-   (notany
-    (lambda (single-member)
-      (ctypep single-member ctype))
-    (cmember-members cmember))
+   (notany (lambda (single-member)
+             (ctypep single-member ctype))
+           (cmember-members cmember))
    t))
 
-(defmethod disjointp ((cmember cmember) (ctype ctype))
-  (member-disjointp cmember ctype))
-
-(defmethod disjointp ((ctype ctype) (cmember cmember))
-  (member-disjointp cmember ctype))
-
 (defmethod conjointp ((ct1 cmember) (ct2 cmember)) (values nil t))
 
 (defmethod cofinitep ((ct cmember)) (values nil t))
@@ -32,17 +24,17 @@
 (defmethod conjoin/2 ((ct1 cmember) (ct2 cmember))
   (apply #'cmember
          (intersection (cmember-members ct1) (cmember-members ct2))))
-(defun conjoin-cmember (cmember ctype)
+
+(define-commutative-method conjoin/2 ((cmember cmember) (ctype ctype))
   ;; FIXME: Could save a little consing by checking subctypep first I guess.
   (apply #'cmember
          (loop for mem in (cmember-members cmember)
                when (ctypep mem ctype) collect mem)))
-(defmethod conjoin/2 ((ct1 cmember) (ct2 ctype)) (conjoin-cmember ct1 ct2))
-(defmethod conjoin/2 ((ct1 ctype) (ct2 cmember)) (conjoin-cmember ct2 ct1))
 
 (defmethod disjoin/2 ((ct1 cmember) (ct2 cmember))
   (apply #'cmember (union (cmember-members ct1) (cmember-members ct2))))
-(defun disjoin-cmember (cmember ctype)
+
+(define-commutative-method disjoin/2 ((cmember cmember) (ctype ctype))
   (let ((non (loop with diff = nil
                    for mem in (cmember-members cmember)
                    if (ctypep mem ctype)
@@ -50,14 +42,10 @@
                    else
                      collect mem
                    ;; If there's no change, give up to avoid recursion
-                   finally (unless diff (return-from disjoin-cmember nil)))))
+                   finally (unless diff (return-from disjoin/2 nil)))))
     (if non
         (disjunction (apply #'cmember non) ctype)
         ctype)))
-(defmethod disjoin/2 ((ct1 cmember) (ct2 ctype))
-  (disjoin-cmember ct1 ct2))
-(defmethod disjoin/2 ((ct1 ctype) (ct2 cmember))
-  (disjoin-cmember ct2 ct1))
 
 (defmethod subtract ((ct1 cmember) (ct2 cmember))
   (apply #'cmember
diff --git a/conjunction.lisp b/conjunction.lisp
index f600b8f..4541af9 100644
--- a/conjunction.lisp
+++ b/conjunction.lisp
@@ -35,21 +35,16 @@
   ;; this also covers the case of ct2 being top.
   (every/tri (lambda (sct) (subctypep ct1 sct)) (junction-ctypes ct2)))
 
-(defmethod disjointp ((ct1 conjunction) (ct2 ctype))
+(define-commutative-method disjointp ((ct1 conjunction) (ct2 ctype))
   ;; if a ^ z = 0 then a ^ b ^ z = 0.
   ;; doesn't follow the other way, though.
   (if (some/tri (lambda (sct) (disjointp sct ct2)) (junction-ctypes ct1))
       (values t t)
       (values nil nil)))
-(defmethod disjointp ((ct1 ctype) (ct2 conjunction))
-  (if (some/tri (lambda (sct) (disjointp ct1 sct)) (junction-ctypes ct2))
-      (values t t)
-      (values nil nil)))
-(defmethod conjointp ((ct1 conjunction) (ct2 ctype))
+
+(define-commutative-method conjointp ((ct1 conjunction) (ct2 ctype))
   ;; (a ^ b) v z = T <=> (a v z) ^ (b v z) = T
   (every/tri (lambda (sct) (conjointp sct ct2)) (junction-ctypes ct1)))
-(defmethod conjointp ((ct1 ctype) (ct2 conjunction))
-  (every/tri (lambda (sct) (conjointp ct1 sct)) (junction-ctypes ct2)))
 
 (defmethod negate ((ctype conjunction))
   ;; de Morgan: ~(a & b) = ~a | ~b
@@ -57,12 +52,10 @@
 
 (defmethod conjoin/2 ((ct1 conjunction) (ct2 conjunction))
   (apply #'conjoin (append (junction-ctypes ct1) (junction-ctypes ct2))))
-(defmethod conjoin/2 ((ct1 conjunction) (ct2 ctype))
+(define-commutative-method conjoin/2 ((ct1 conjunction) (ct2 ctype))
   (apply #'conjoin ct2 (junction-ctypes ct1)))
-(defmethod conjoin/2 ((ct1 ctype) (ct2 conjunction))
-  (apply #'conjoin ct1 (junction-ctypes ct2)))
 
-(defun disjoin-conjunction (conjunction ctype)
+(define-commutative-method disjoin/2 ((conjunction conjunction) (ctype ctype))
   ;; If any disjunction is uninteresting, give up - except that if some
   ;; of the disjunctions are T, factor those out.
   ;; (This factoring is important for correctly computing that (or x (not x))
@@ -84,10 +77,6 @@
                          (disjunction ctype
                                       (apply #'conjunction uninteresting)))
                         (t nil)))))
-(defmethod disjoin/2 ((ct1 conjunction) (ct2 ctype))
-  (disjoin-conjunction ct1 ct2))
-(defmethod disjoin/2 ((ct1 ctype) (ct2 conjunction))
-  (disjoin-conjunction ct2 ct1))
 
 (defmethod unparse ((ct conjunction))
   (let ((ups (mapcar #'unparse (junction-ctypes ct))))
diff --git a/ctype.asd b/ctype.asd
index d31fbb6..33345df 100644
--- a/ctype.asd
+++ b/ctype.asd
@@ -57,3 +57,17 @@
                                      "cfunction" "packages"))
    (:file "parse"
     :depends-on ("generic-functions" "create" "classes" "config" "packages"))))
+
+(asdf:defsystem :ctype/ext
+  :license "BSD"
+  :depends-on (:ctype :alexandria)
+  :components
+  ((:module "ext"
+    :components
+    ((:file "packages")
+     (:module "data-structures"
+      :depends-on ("packages")
+      :components
+      ((:file "list-of")
+       (:file "array-of")
+       (:file "hash-table-of")))))))
diff --git a/disjunction.lisp b/disjunction.lisp
index 7af07fa..4d529df 100644
--- a/disjunction.lisp
+++ b/disjunction.lisp
@@ -50,19 +50,13 @@
                             (values nil t)
                             (values nil nil)))))
 
-(defmethod disjointp ((ct1 disjunction) (ct2 ctype))
+(define-commutative-method disjointp ((ct1 disjunction) (ct2 ctype))
   ;; (a v b) ^ z = 0 <=> (a ^ z) v (b ^ z) = 0
   (every/tri (lambda (sct) (disjointp sct ct2)) (junction-ctypes ct1)))
-(defmethod disjointp ((ct1 ctype) (ct2 disjunction))
-  (every/tri (lambda (sct) (disjointp ct1 sct)) (junction-ctypes ct2)))
-(defmethod conjointp ((ct1 disjunction) (ct2 ctype))
+(define-commutative-method conjointp ((ct1 disjunction) (ct2 ctype))
   (if (some/tri (lambda (sct) (conjointp sct ct2)) (junction-ctypes ct1))
       (values t t)
       (values nil nil)))
-(defmethod conjointp ((ct1 ctype) (ct2 disjunction))
-  (if (some/tri (lambda (sct) (conjointp ct1 sct)) (junction-ctypes ct2))
-      (values t t)
-      (values nil nil)))
 
 (defmethod negate ((ctype disjunction))
   (apply #'conjoin (mapcar #'negate (junction-ctypes ctype))))
@@ -70,19 +64,13 @@
 (defmethod disjoin/2 ((ct1 disjunction) (ct2 disjunction))
   (apply #'disjoin (append (junction-ctypes ct1)
                            (junction-ctypes ct2))))
-(defmethod disjoin/2 ((ct1 disjunction) (ct2 ctype))
+(define-commutative-method disjoin/2 ((ct1 disjunction) (ct2 ctype))
   (apply #'disjoin ct2 (junction-ctypes ct1)))
-(defmethod disjoin/2 ((ct1 ctype) (ct2 disjunction))
-  (apply #'disjoin ct1 (junction-ctypes ct2)))
 
-(defun conjoin-disjunction (disjunction ctype)
+(define-commutative-method conjoin/2 ((disjunction disjunction) (ctype ctype))
   (apply #'disjoin
          (loop for sct in (junction-ctypes disjunction)
                collect (conjoin sct ctype))))
-(defmethod conjoin/2 ((ct1 disjunction) (ct2 ctype))
-  (conjoin-disjunction ct1 ct2))
-(defmethod conjoin/2 ((ct1 ctype) (ct2 disjunction))
-  (conjoin-disjunction ct2 ct1))
 
 (defmethod unparse ((ct disjunction))
   (let ((ups (mapcar #'unparse (junction-ctypes ct))))
diff --git a/ext/README.md b/ext/README.md
index 58bf94c..5cb3bf0 100644
--- a/ext/README.md
+++ b/ext/README.md
@@ -6,9 +6,13 @@ For example, the set of all `evenp` integers is `(ctype.ext.mod:congruence 2 #b0
 
 The type of all integers that are not a multiple of three (i.e. that are 1 mod 3 or 2 mod 3) would be `(congruence 3 #b110)`. This too can be conjoined and disjoined at will, e.g. `(conjoin (congruence 3 #b110) (congruence 2 #b01))` => 2 or 4 mod 6, while `(disjoin (congruence 3 #b110) (congruence 2 #b01))` => 0, 1, 2, 4, or 5 mod 6. The conjunctions and disjunctions of congruences are always either congruences, `integer`, or `nil`.
 
-# Indefinite-length lists
+# Homogeneous Data Structures
 
-The `list-of.lisp` file is a self contained implementation of the type of lists of some element type. This type cannot be expressed in the Common Lisp type system but is sometimes desired. In a little more detail, `(list-of x)` can be expressed recursively as being the object `nil` plus all objects of type `(cons x (list-of x))`. This includes circular lists, but not dotted lists.
+They can be loaded with the `ctype/ext` ASDF system which has ctype and alexandria as dependencies.
+
+The `list-of` extended type is an implementation of the type of lists of some element type. This type cannot be expressed in the Common Lisp type system but is sometimes desired. In a little more detail, `(list-of x)` can be expressed recursively as being the object `nil` plus all objects of type `(cons x (list-of x))`. This includes circular lists, but not dotted lists.
+
+Types for arrays and hash-tables of some element type(s) have also been defined as `array-of` and `hash-table-of`.
 
 # Type-level functions
 
diff --git a/ext/data-structures/array-of.lisp b/ext/data-structures/array-of.lisp
new file mode 100644
index 0000000..ae4041f
--- /dev/null
+++ b/ext/data-structures/array-of.lisp
@@ -0,0 +1,184 @@
+(in-package #:ctype.ext.data-structures)
+
+(defclass carray-of (carray) ()
+  (:documentation "Homogeneous array ctype."))
+
+(defun carray-of (element-ctype &optional (dims '*) (upgraded-element-type '*) simplicity)
+  (if simplicity
+      (make-instance
+       'carray-of
+       :simplicity simplicity :uaet upgraded-element-type :eaet element-ctype :dims dims))
+  (let ((simple
+          (make-instance
+           'carray-of
+           :simplicity :simple :uaet upgraded-element-type :eaet element-ctype :dims dims)))
+    (if ctype:+complex-arrays-exist-p+
+        (disjoin simple
+                 (make-instance
+                  'carray-of
+                  :simplicity :complex :uaet upgraded-element-type :eaet element-ctype :dims dims))
+        simple)))
+
+(define-extended-type array-of (element-type &optional (dims '*) (upgraded-element-type '*) &environment env)
+  :documentation "An array whose elements are of type ELEMENT-TYPE."
+  :simple ((declare (ignore upgraded-element-type env))
+           `(array ,element-type ,dims))
+  :extended
+  ((carray-of (extended-specifier-ctype element-type env) dims upgraded-element-type)))
+
+(defun simple-carray-of (element-ctype &optional (dims '*) (upgraded-element-type '*))
+  (make-instance
+   'carray-of
+   :simplicity :simple :uaet upgraded-element-type :eaet element-ctype :dims dims))
+
+(define-extended-type simple-array-of (element-type &optional (dims '*) (upgraded-element-type '*) &environment env)
+  :documentation "A simple array whose elements are of type ELEMENT-TYPE."
+  :simple ((declare (ignore upgraded-element-type env))
+           `(simple-array ,element-type ,dims))
+  :extended
+  ((simple-carray-of (extended-specifier-ctype element-type env) dims upgraded-element-type)))
+
+(defun cvector-of (element-ctype &optional (length '*) (upgraded-element-type '*) simplicity)
+  (carray-of
+   element-ctype
+   (if (eq length '*)
+       length
+       (list length))
+   upgraded-element-type simplicity))
+
+(define-extended-type vector-of (element-type &optional (length '*) (upgraded-element-type '*) &environment env)
+  :documentation "A vector whose elements are of type ELEMENT-TYPE."
+  :simple ((declare (ignore upgraded-element-type env))
+           `(vector ,element-type ,length))
+  :extended
+  ((cvector-of (extended-specifier-ctype element-type env) length upgraded-element-type)))
+
+(defun simple-cvector-of (element-ctype &optional (length '*) (upgraded-element-type '*))
+  (simple-carray-of
+   element-ctype
+   (if (eq length '*)
+       length
+       (list length))
+   upgraded-element-type))
+
+(define-extended-type simple-vector-of (element-type &optional (length '*) (upgraded-element-type '*) &environment env)
+  :documentation "A simple vector whose elements are of type ELEMENT-TYPE."
+  :simple ((declare (ignore upgraded-element-type env))
+           `(simple-vector ,element-type ,length))
+  :extended
+  ((simple-cvector-of (extended-specifier-ctype element-type env) length upgraded-element-type)))
+
+(defun unparse-vector-simple (type length)
+  (let* ((front (case type
+                  ((bit) '(simple-bit-vector))
+                  ((base-char) '(simple-base-string))
+                  (otherwise '(simple-vector type))))
+         (back (if (eq length '*)
+                   nil
+                   (list length)))
+         (all (append front back)))
+    (if (= (length all) 1)
+        (first all)
+        all)))
+
+(defmethod unparse ((ct carray-of))
+  (let* ((element-type (unparse (carray-eaet ct)))
+         (dims (carray-dims ct))
+         (tail (if (eq dims '*)
+                   (if (eq element-type '*)
+                       nil
+                       `(,element-type))
+                   `(,element-type ,dims))))
+    (if (eq (carray-simplicity ct) :simple)
+        (cond ((null tail) 'simple-array)
+              ((and (not (eq dims '*))
+                    (= (length dims) 1)
+                    (unparse-vector-simple element-type (first dims))))
+              (t `(simple-array ,@tail)))
+        (if (null tail)
+            '(and array (not simple-array))
+            `(and (array ,@tail) (not simple-array))))))
+
+(defmethod ctypep ((object array) (ct carray-of))
+  (let ((element-ctype (carray-eaet ct))
+        (dims (carray-dims ct)))
+    (and (or (eq dims '*)
+             (let ((rank (length dims)))
+               (and (= (array-rank object) rank)
+                    (loop for i from 0 below rank
+                          for dim in dims
+                          always (or (eq dim '*)
+                                     (= (array-dimension object i) dim))))))
+         (let ((all-indexes (mapcar #'iota (array-dimensions object))))
+           (block check-elements-types
+             (apply #'map-product
+                    (lambda (&rest indexes)
+                      (unless (ctypep (apply #'aref object indexes) element-ctype)
+                        (return-from check-elements-types nil)))
+                    all-indexes)
+             t)))))
+(defmethod ctypep ((object t) (ct carray-of)) nil)
+
+(defmethod subctypep ((ct1 carray-of) (ct2 carray-of))
+  (let ((element-ctype1 (carray-eaet ct1))
+        (dims1 (carray-dims ct1))
+        (simplicity1 (carray-simplicity ct1))
+        (element-ctype2 (carray-eaet ct2))
+        (dims2 (carray-dims ct2))
+        (simplicity2 (carray-simplicity ct2)))
+    (and/tri
+     (subctypep element-ctype1 element-ctype2)
+     (values
+      (and (eq simplicity1 simplicity2)
+           (or (eq dims2 '*)
+               (and (not (eq dims1 '*))
+                    (= (length dims1) (length dims2))
+                    (loop for dim1 in dims1
+                          for dim2 in dims2
+                          always (or (eq dim2 '*)
+                                     (and (not (eq dim1 '*))
+                                          (= dim1 dim2)))))))
+      t))))
+
+(defmethod conjoin/2 ((array1 carray-of) (array2 carray-of))
+  (let ((uaet1 (carray-uaet array1))
+        (eaet1 (carray-eaet array1))
+        (dims1 (carray-dims array1))
+        (simplicity1 (carray-simplicity array1))
+        (uaet2 (carray-uaet array2))
+        (eaet2 (carray-eaet array2))
+        (dims2 (carray-dims array2))
+        (simplicity2 (carray-simplicity array2)))
+    (let ((new-simplicity
+            (cond ((eq simplicity1 :simple)
+                   (unless (eq simplicity2 :simple)
+                     ;; simplicity mismatch
+                     (return-from conjoin/2 (bot)))
+                   simplicity1)
+                  ((eq simplicity1 :complex)
+                   (unless (eq simplicity2 :complex)
+                     (return-from conjoin/2 (bot)))
+                   simplicity2)))
+          (new-uaet
+            (cond ((eq uaet1 '*) uaet2)
+                  ((eq uaet2 '*) uaet1)
+                  ((equal uaet1 uaet2) uaet1)
+                  ;; UAET mismatch
+                  (t (return-from conjoin/2 (bot)))))
+          (new-dims
+            (cond ((eq dims2 '*) dims1)
+                  ((eq dims1 '*) dims2)
+                  ((= (length dims1) (length dims2))
+                   (loop for dim1 in dims1
+                         for dim2 in dims2
+                         collect (cond ((eq dim1 '*) dim2)
+                                       ((eq dim2 '*) dim1)
+                                       ((= dim1 dim2) dim1)
+                                       ;; Dimension mismatch
+                                       (t (return-from conjoin/2 (bot))))))
+                  (t ;; Rank mismatch
+                   (return-from conjoin/2 (bot)))))
+          (new-eaet (conjoin eaet1 eaet2)))
+      (if (bot-p new-eaet)
+          (bot)
+          (carray-of new-eaet new-dims new-uaet new-simplicity)))))
diff --git a/ext/data-structures/hash-table-of.lisp b/ext/data-structures/hash-table-of.lisp
new file mode 100644
index 0000000..428a99f
--- /dev/null
+++ b/ext/data-structures/hash-table-of.lisp
@@ -0,0 +1,88 @@
+(in-package #:ctype.ext.data-structures)
+
+(defclass chash-table-of (ctype)
+  ((%key-type :initarg :key :reader key-ctype)
+   (%value-type :initarg :value :reader value-ctype))
+  (:documentation "Homogeneous hash-table ctype."))
+
+(defmethod unparse ((object chash-table-of))
+  `(hash-table-of ,(unparse (key-ctype object))
+                  ,(unparse (value-ctype object))))
+
+(defun chash-table-of (key-ctype value-ctype)
+  (make-instance
+   'chash-table-of
+   :key key-ctype
+   :value value-ctype))
+
+(define-extended-type hash-table-of (key-type value-type &environment env)
+  :documentation "A hash-table whose keys are of type KEY-TYPE and values are of type VALUE-TYPE."
+  :simple ((declare (ignore key-type value-type env))
+           'hash-table)
+  :extended
+  ((chash-table-of (extended-specifier-ctype key-type env)
+                   (extended-specifier-ctype value-type env))))
+
+(defmethod ctypep ((object t) (ctype chash-table-of)) nil)
+(defmethod ctypep ((object hash-table) (ctype chash-table-of))
+  (let ((key-ctype (key-ctype ctype))
+        (value-ctype (value-ctype ctype)))
+    (loop for key being each hash-key of object using (hash-value value) do
+      (unless (and (ctypep key key-ctype)
+                   (ctypep value value-ctype))
+        (return-from ctypep nil))))
+  t)
+
+(defun compare-chash-table-of (predicate combiner ctype1 ctype2)
+  (let ((key1 (key-ctype ctype1))
+        (key2 (key-ctype ctype2))
+        (value1 (value-ctype ctype1))
+        (value2 (value-ctype ctype2)))
+    (multiple-value-bind (key-comparison key-valid) (funcall predicate key1 key2)
+      (multiple-value-bind (value-comparison value-valid) (funcall predicate value1 value2)
+        (values (funcall combiner (list key-comparison value-comparison))
+                (funcall combiner #'identity (list key-valid value-valid)))))))
+
+(defmethod subctypep ((ctype1 chash-table-of) (ctype2 cclass))
+  (values
+   (eql (find-class 'hash-table)
+        (cclass-class ctype2))
+   t))
+
+(defmethod subctypep ((ctype1 chash-table-of) (ctype2 chash-table-of))
+  (compare-chash-table-of
+   #'subctypep #'every
+   ctype1 ctype2))
+
+(defmethod ctype= ((ctype1 chash-table-of) (ctype2 chash-table-of))
+  (compare-chash-table-of
+   #'ctype= #'every
+   ctype1 ctype2))
+
+(defmethod disjointp ((ctype1 chash-table-of) (ctype2 chash-table-of))
+  (compare-chash-table-of
+   #'disjointp #'some
+   ctype1 ctype2))
+
+(defmethod cofinitep ((ctype chash-table-of)) (values nil t))
+
+(defmethod conjoin/2 ((ct1 chash-table-of) (ct2 chash-table-of))
+  (let ((key (conjoin (key-ctype ct1) (key-ctype ct2)))
+        (value (conjoin (value-ctype ct1) (value-ctype ct2))))
+    (if (or (bot-p key) (bot-p value))
+        (bot)
+        (chash-table-of key value))))
+
+(defmethod subtract ((ct1 chash-table-of) (ct2 chash-table-of))
+  (let ((key (conjoin (key-ctype ct1) (negate (key-ctype ct2))))
+        (value (conjoin (value-ctype ct1) (negate (value-ctype ct2)))))
+    (if (or (bot-p key) (bot-p value))
+        (bot)
+        (chash-table-of key value))))
+
+(defexclusives chash-table-of range ccomplex carray charset cfunction fpzero)
+
+(define-commutative-method conjointp ((ct1 cclass) (ct2 chash-table-of))
+  (values nil t))
+
+(defexistential chash-table-of)
diff --git a/ext/data-structures/list-of.lisp b/ext/data-structures/list-of.lisp
new file mode 100644
index 0000000..12c30d9
--- /dev/null
+++ b/ext/data-structures/list-of.lisp
@@ -0,0 +1,96 @@
+(in-package #:ctype.ext.data-structures)
+
+(defclass clist-of (ctype)
+  ((%etype :initarg :etype :reader element-ctype))
+  (:documentation "Proper homogeneous list ctype."))
+
+(defmethod unparse ((object clist-of))
+  `(list-of ,(unparse (element-ctype object))))
+
+(defun clist-of (ect)
+  (if (bot-p ect)
+      (cmember nil)
+      (make-instance 'clist-of :etype ect)))
+
+(define-extended-type list-of (element-type &environment env)
+  :documentation "A proper list whose elements are all of type ELEMENT-TYPE."
+  :simple ((declare (ignore element-type env))
+           'list)
+  :extended
+  ((clist-of (extended-specifier-ctype element-type env))))
+
+(defmethod ctypep ((object null) (ct clist-of)) t)
+(defmethod ctypep ((object cons) (ct clist-of))
+  (let ((ect (element-ctype ct)))
+    (and (ctypep (car object) ect)
+         ;; Traverse circular lists carefully
+         (loop for sub = (cdr object) then (cdr sub)
+               until (or (null sub) (eq sub object))
+               unless (ctypep (car sub) ect)
+                 return nil
+               finally (return t)))))
+(defmethod ctypep ((object t) (ct clist-of)) nil)
+
+(defmethod subctypep ((ct1 clist-of) (ct2 clist-of))
+  (subctypep (element-ctype ct1) (element-ctype ct2)))
+(defmethod ctype= ((ct1 clist-of) (ct2 clist-of))
+  (ctype= (element-ctype ct1) (element-ctype ct2)))
+
+(defmethod disjointp ((ct1 clist-of) (ct2 clist-of))
+  (disjointp (element-ctype ct1) (element-ctype ct2)))
+(defmethod conjointp ((ct1 clist-of) (ct2 clist-of)) (values nil t))
+
+(defmethod cofinitep ((ct clist-of)) (values nil t))
+
+(defmethod conjoin/2 ((ct1 clist-of) (ct2 clist-of))
+  (clist-of (conjoin (element-ctype ct1) (element-ctype ct2))))
+(defmethod disjoin/2 ((ct1 clist-of) (ct2 clist-of))
+  (clist-of (disjoin (element-ctype ct1) (element-ctype ct2))))
+
+(defmethod subtract ((ct1 clist-of) (ct2 clist-of))
+  (clist-of (conjoin (element-ctype ct1) (negate (element-ctype ct2)))))
+
+;;;
+
+(defmethod subctypep ((ct1 clist-of) (ct2 ccons))
+  ;; clist-of includes nil, a non-cons
+  (values nil t))
+(defmethod subctypep ((ct1 ccons) (ct2 clist-of))
+  ;; cons types are never recursive, so they can't be subtype of clist-of
+  ;; except in the degenerate cons type case.
+  ;; (Note that we don't need to worry about degenerate clist-of,
+  ;;  since (clist-of nil) is not nil, it's null.)
+  (or/tri (subctypep (ccons-car ct1) (bot))
+          (subctypep (ccons-cdr ct1) (bot))))
+
+(defmethod subctypep ((ct1 cmember) (ct2 clist-of))
+  (values (equal (cmember-members ct1) '(nil)) t))
+
+(define-commutative-method disjointp ((clist-of clist-of) (ccons ccons))
+  (or/tri (disjointp (ccons-car ccons) (element-ctype clist-of))
+          (disjointp (ccons-cdr ccons) clist-of)))
+
+(define-commutative-method disjointp ((clist-of clist-of) (cmember cmember))
+  (values (not (member nil (cmember-members cmember))) t))
+
+(defexclusives clist-of range ccomplex carray charset cfunction fpzero)
+
+(define-commutative-method conjointp ((ct1 clist-of) (ct2 cclass))
+  (values nil t))
+
+;;; LIST is a subtype of SEQUENCE, so all CLIST-OF types are as well.
+(defun sequence-cclass-p (cclass)
+  (eq (class-name (cclass-class cclass)) 'sequence))
+(defmethod subctypep ((ct1 clist-of) (ct2 cclass))
+  (values (sequence-cclass-p ct2) t))
+(defmethod subctypep ((ct1 cclass) (ct2 clist-of)) (values nil t))
+(define-commutative-method disjointp ((ct1 clist-of) (ct2 cclass))
+  (values (not (sequence-cclass-p ct2)) t))
+(define-commutative-method conjoin/2 ((ct1 clist-of) (ct2 cclass))
+  (if (sequence-cclass-p ct2) ct1 (bot)))
+(define-commutative-method disjoin/2 ((ct1 clist-of) (ct2 cclass))
+  (if (sequence-cclass-p ct2) ct2 nil))
+(defmethod subtract ((ct1 clist-of) (ct2 cclass))
+  (if (sequence-cclass-p ct2) (bot) ct1))
+(defmethod subtract ((ct1 cclass) (ct2 clist-of))
+  (if (sequence-cclass-p ct1) nil (bot)))
diff --git a/ext/list-of.lisp b/ext/list-of.lisp
deleted file mode 100644
index e7ac20b..0000000
--- a/ext/list-of.lisp
+++ /dev/null
@@ -1,116 +0,0 @@
-(defpackage #:ctype.ext.list-of
-  (:use #:cl #:ctype)
-  (:export #:list-of))
-
-(in-package #:ctype.ext.list-of)
-
-(defclass list-of (ctype)
-  ((%etype :initarg :etype :reader element-ctype)))
-
-(defun list-of (ect)
-  (if (bot-p ect)
-      (cmember nil)
-      (make-instance 'list-of :etype ect)))
-
-(defmethod ctypep ((object null) (ct list-of)) t)
-(defmethod ctypep ((object cons) (ct list-of))
-  (let ((ect (element-ctype ct)))
-    (and (ctypep (car object) ect)
-         ;; Traverse circular lists carefully
-         (loop for sub = (cdr object) then (cdr sub)
-               until (or (null sub) (eq sub object))
-               unless (ctypep (car sub) ect)
-                 return nil
-               finally (return t)))))
-(defmethod ctypep ((object t) (ct list-of)) nil)
-
-(defmethod subctypep ((ct1 list-of) (ct2 list-of))
-  (subctypep (element-ctype ct1) (element-ctype ct2)))
-(defmethod ctype= ((ct1 list-of) (ct2 list-of))
-  (ctype= (element-ctype ct1) (element-ctype ct2)))
-
-(defmethod disjointp ((ct1 list-of) (ct2 list-of))
-  (disjointp (element-ctype ct1) (element-ctype ct2)))
-(defmethod conjointp ((ct1 list-of) (ct2 list-of)) (values nil t))
-
-(defmethod cofinitep ((ct list-of)) (values nil t))
-
-(defmethod conjoin/2 ((ct1 list-of) (ct2 list-of))
-  (list-of (conjoin (element-ctype ct1) (element-ctype ct2))))
-(defmethod disjoin/2 ((ct1 list-of) (ct2 list-of))
-  (list-of (disjoin (element-ctype ct1) (element-ctype ct2))))
-
-(defmethod subtract ((ct1 list-of) (ct2 list-of))
-  (list-of (conjoin (element-ctype ct1) (negate (element-ctype ct2)))))
-
-;;;
-
-(defmethod subctypep ((ct1 list-of) (ct2 ccons))
-  ;; list-of includes nil, a non-cons
-  (values nil t))
-(defmethod subctypep ((ct1 ccons) (ct2 list-of))
-  ;; cons types are never recursive, so they can't be subtype of list-of
-  ;; except in the degenerate cons type case.
-  ;; (Note that we don't need to worry about degenerate list-of,
-  ;;  since (list-of nil) is not nil, it's null.)
-  (or/tri (subctypep (ccons-car ct1) (bot))
-          (subctypep (ccons-cdr ct2) (bot))))
-
-(defmethod subctypep ((ct1 cmember) (ct2 list-of))
-  (values (equal (cmember-members ct1) '(nil)) t))
-
-(defun clo-disjointp (ccons list-of)
-  (or/tri (disjointp (ccons-car ccons) (element-ctype list-of))
-          (disjointp (ccons-cdr ccons) list-of)))
-(defmethod disjointp ((ct1 list-of) (ct2 ccons)) (clo-disjointp ct2 ct1))
-(defmethod disjointp ((ct1 ccons) (ct2 list-of)) (clo-disjointp ct1 ct2))
-
-(defun mlo-disjointp (cmember)
-  (values (not (member nil (cmember-members cmember))) t))
-(defmethod disjointp ((ct1 list-of) (ct2 cmember)) (mlo-disjointp ct2))
-(defmethod disjointp ((ct1 cmember) (ct2 list-of)) (mlo-disjointp ct1))
-
-(macrolet ((defexclusive (class)
-             `(progn
-                (defmethod subctypep ((ct1 list-of) (ct2 ,class))
-                  (values nil t))
-                (defmethod subctypep ((ct1 ,class) (ct2 list-of))
-                  (values nil t))
-                (defmethod disjointp ((ct1 list-of) (ct2 ,class))
-                  (values t t))
-                (defmethod disjointp ((ct1 ,class) (ct2 list-of))
-                  (values t t))
-                (defmethod conjointp ((ct1 list-of) (ct2 ,class))
-                  (values nil t))
-                (defmethod conjointp ((ct1 ,class) (ct2 list-of))
-                  (values nil t))))
-           (defexclusives (&rest classes)
-             `(progn ,@(loop for class in classes
-                             collect `(defexclusive ,class)))))
-  (defexclusives range ccomplex carray charset cfunction fpzero))
-
-(defmethod conjointp ((ct1 list-of) (ct2 cclass)) (values nil t))
-(defmethod conjointp ((ct1 cclass) (ct2 list-of)) (values nil t))
-
-;;; LIST is a subtype of SEQUENCE, so all LIST-OF types are as well.
-(defun sequence-cclass-p (cclass)
-  (eq (class-name (cclass-class cclass)) 'sequence))
-(defmethod subctypep ((ct1 list-of) (ct2 cclass))
-  (values (sequence-cclass-p ct2) t))
-(defmethod subctypep ((ct1 cclass) (ct2 list-of)) (values nil t))
-(defmethod disjointp ((ct1 list-of) (ct2 cclass))
-  (values (not (sequence-cclass-p ct2)) t))
-(defmethod disjointp ((ct1 cclass) (ct2 list-of))
-  (values (not (sequence-cclass-p ct2)) t))
-(defmethod conjoin/2 ((ct1 list-of) (ct2 cclass))
-  (if (sequence-cclass-p ct2) ct1 (bot)))
-(defmethod conjoin/2 ((ct1 cclass) (ct2 list-of))
-  (if (sequence-cclass-p ct1) ct2 (bot)))
-(defmethod disjoin/2 ((ct1 list-of) (ct2 cclass))
-  (if (sequence-cclass-p ct2) ct2 nil))
-(defmethod disjoin/2 ((ct1 cclass) (ct2 list-of))
-  (if (sequence-cclass-p ct1) ct1 nil))
-(defmethod subtract ((ct1 list-of) (ct2 cclass))
-  (if (sequence-cclass-p ct2) (bot) ct1))
-(defmethod subtract ((ct1 cclass) (ct2 list-of))
-  (if (sequence-cclass-p ct1) nil (bot)))
diff --git a/ext/mod.lisp b/ext/mod.lisp
index 686a53f..c29f61d 100644
--- a/ext/mod.lisp
+++ b/ext/mod.lisp
@@ -155,7 +155,8 @@
           (null (range-high ct1)))
       (values nil t)
       (values nil nil)))
-(defun congrange-disjointp (range)
+
+(define-commutative-method disjointp ((congruence congruence) (range range))
   ;; FIXME: Inaccurate in basically the same way.
   (if (or (not (eq (range-kind range) 'integer))
           ;; A range unbounded on one side necessarily includes all
@@ -165,28 +166,8 @@
           (null (range-high range)))
       (values t t)
       (values nil nil)))
-(defmethod disjointp ((ct1 congruence) (ct2 range))
-  (congrange-disjointp ct2))
-(defmethod disjointp ((ct1 range) (ct2 congruence))
-  (congrange-disjointp ct1))
-(defmethod conjointp ((ct1 congruence) (ct2 range)) (values nil t))
-(defmethod conjointp ((ct1 range) (ct2 congruence)) (values nil t))
-
-(macrolet ((defexclusive (class)
-             `(progn
-                (defmethod subctypep ((ct1 congruence) (ct2 ,class))
-                  (values nil t))
-                (defmethod subctypep ((ct1 ,class) (ct2 congruence))
-                  (values nil t))
-                (defmethod disjointp ((ct1 congruence) (ct2 ,class))
-                  (values t t))
-                (defmethod disjointp ((ct1 ,class) (ct2 congruence))
-                  (values t t))
-                (defmethod conjointp ((ct1 congruence) (ct2 ,class))
-                  (values nil t))
-                (defmethod conjointp ((ct1 ,class) (ct2 congruence))
-                  (values nil t))))
-           (defexclusives (&rest classes)
-             `(progn ,@(loop for class in classes
-                             collect `(defexclusive ,class)))))
-  (defexclusives cclass ccomplex carray charset cfunction fpzero))
+
+(define-commutative-method conjointp ((ct1 congruence) (ct2 range))
+  (values nil t))
+
+(defexclusives congruence cclass ccomplex carray charset cfunction fpzero)
diff --git a/ext/packages.lisp b/ext/packages.lisp
new file mode 100644
index 0000000..a0a2e8b
--- /dev/null
+++ b/ext/packages.lisp
@@ -0,0 +1,18 @@
+(defpackage #:ctype.ext.data-structures
+  (:use #:cl #:ctype)
+  (:import-from #:alexandria
+                #:map-product
+                #:iota)
+  ;; ctypes
+  (:export
+   #:clist-of
+   #:carray-of
+   #:chash-table-of)
+  ;; extended types
+  (:export
+   #:list-of
+   #:array-of
+   #:simple-array-of
+   #:vector-of
+   #:simple-vector-of
+   #:hash-table-of))
diff --git a/ext/tfun/tfun.lisp b/ext/tfun/tfun.lisp
index 273aac9..c980b9b 100644
--- a/ext/tfun/tfun.lisp
+++ b/ext/tfun/tfun.lisp
@@ -12,25 +12,12 @@
 (defmethod subctypep ((ct1 tfun) (ct2 cfunction))
   (if (function-top-p ct2) (values t t) (values nil nil)))
 (defmethod subctypep ((ct1 cfunction) (ct2 tfun)) (values nil t))
-(defmethod disjointp ((ct1 tfun) (ct2 cfunction))
+(define-commutative-method disjointp ((ct1 tfun) (ct2 cfunction))
   (if (function-top-p ct2) (values nil t) (values nil nil)))
-(defmethod disjointp ((ct1 cfunction) (ct2 tfun))
-  (if (function-top-p ct1) (values nil t) (values nil nil)))
-(defmethod conjointp ((ct1 tfun) (ct2 cfunction)) (values nil t))
-(defmethod conjointp ((ct1 cfunction) (ct2 tfun)) (values nil t))
+(define-commutative-method conjointp ((ct1 tfun) (ct2 cfunction))
+  (values nil t))
 
-(macrolet ((defexclusive (class)
-             `(progn
-                (defmethod subctypep ((ct1 tfun) (ct2 ,class)) (values nil t))
-                (defmethod subctypep ((ct1 ,class) (ct2 tfun)) (values nil t))
-                (defmethod disjointp ((ct1 tfun) (ct2 ,class)) (values t t))
-                (defmethod disjointp ((ct1 ,class) (ct2 tfun)) (values t t))
-                (defmethod conjointp ((ct1 tfun) (ct2 ,class)) (values nil t))
-                (defmethod conjointp ((ct1 ,class) (ct2 tfun)) (values nil t))))
-           (defexclusives (&rest classes)
-             `(progn ,@(loop for class in classes
-                             collect `(defexclusive ,class)))))
-  (defexclusives cclass ccomplex carray charset fpzero range))
+(defexclusives tfun cclass ccomplex carray charset fpzero range))
 
 ;;;
 
diff --git a/generic-functions.lisp b/generic-functions.lisp
index 9f237f2..863dbda 100644
--- a/generic-functions.lisp
+++ b/generic-functions.lisp
@@ -1,5 +1,10 @@
 (in-package #:ctype)
 
+(defmacro define-commutative-method (name (arg1 arg2) &body body)
+  `(progn
+     (defmethod ,name (,arg1 ,arg2) ,@body)
+     (defmethod ,name (,arg2 ,arg1) ,@body)))
+
 (defgeneric ctypep (object ctype)
   (:argument-precedence-order ctype object))
 
diff --git a/negation.lisp b/negation.lisp
index 50a03ef..5a6f1cd 100644
--- a/negation.lisp
+++ b/negation.lisp
@@ -33,18 +33,14 @@
 (defmethod disjointp ((ct1 negation) (ct2 negation))
   ;; ~a ^ ~b = 0 <=> ~(a v b) = 0 <=> a v b = T
   (conjointp (negation-ctype ct1) (negation-ctype ct2)))
-(defmethod disjointp ((ct1 negation) (ct2 ctype))
+(define-commutative-method disjointp ((ct1 negation) (ct2 ctype))
   (subctypep ct2 (negation-ctype ct1)))
-(defmethod disjointp ((ct1 ctype) (ct2 negation))
-  (subctypep ct1 (negation-ctype ct2)))
 
 (defmethod conjointp ((ct1 negation) (ct2 negation))
   ;; ~a v ~b = T <=> ~(a ^ b) = T <=> a ^ b = 0
   (disjointp (negation-ctype ct1) (negation-ctype ct2)))
-(defmethod conjointp ((ct1 negation) (ct2 ctype))
+(define-commutative-method conjointp ((ct1 negation) (ct2 ctype))
   (subctypep (negation-ctype ct1) ct2))
-(defmethod conjointp ((ct1 ctype) (ct2 negation))
-  (subctypep (negation-ctype ct2) ct1))
 
 (defmethod negate ((ctype negation)) (negation-ctype ctype))
 
@@ -59,10 +55,8 @@
              (if p
                  (negate p)
                  nil))))))
-(defmethod conjoin/2 ((ct1 negation) (ct2 ctype))
+(define-commutative-method conjoin/2 ((ct1 negation) (ct2 ctype))
   (subtract ct2 (negation-ctype ct1)))
-(defmethod conjoin/2 ((ct1 ctype) (ct2 negation))
-  (subtract ct1 (negation-ctype ct2)))
 
 (defmethod disjoin/2 ((ct1 negation) (ct2 negation))
   (let ((nt1 (negation-ctype ct1)) (nt2 (negation-ctype ct2)))
@@ -73,14 +67,10 @@
                (if p
                    (negate p)
                    nil))))))
-(defmethod disjoin/2 ((ct1 negation) (ct2 ctype))
+(define-commutative-method disjoin/2 ((ct1 negation) (ct2 ctype))
   (if (subctypep (negation-ctype ct1) ct2)
       (top)
       nil))
-(defmethod disjoin/2 ((ct1 ctype) (ct2 negation))
-  (if (subctypep (negation-ctype ct2) ct1)
-      (top)
-      nil))
 
 (defmethod subtract ((ct1 ctype) (ct2 negation))
   (conjoin/2 ct1 (negation-ctype ct2)))
diff --git a/packages.lisp b/packages.lisp
index 502bbac..3e354d5 100644
--- a/packages.lisp
+++ b/packages.lisp
@@ -1,6 +1,6 @@
 (defpackage #:ctype
   (:use #:cl)
-  (:export #:specifier-ctype #:values-specifier-ctype)
+  (:export #:specifier-ctype #:extended-specifier-ctype #:values-specifier-ctype)
   (:export #:ctypep #:subctypep #:ctype=)
   (:export #:disjointp #:conjointp #:cofinitep)
   (:export #:negate #:conjoin/2 #:disjoin/2 #:subtract #:unparse
@@ -8,7 +8,11 @@
   ;; Useful for extensions.
   (:export #:basic
            #:every/tri #:some/tri #:notevery/tri #:notany/tri
-           #:and/tri #:or/tri #:surely)
+           #:and/tri #:or/tri #:surely
+           #:defexistential #:defexclusives
+           #:define-commutative-method
+           #:define-extended-type
+           #:+complex-arrays-exist-p+)
   ;; Interface to interrogate information about types.
   ;; EXPERIMENTAL, SUBJECT TO CHANGE.
   (:export #:ctype
diff --git a/pairwise.lisp b/pairwise.lisp
index 8f21fd6..d14b2dc 100644
--- a/pairwise.lisp
+++ b/pairwise.lisp
@@ -8,10 +8,12 @@
 
 (defmacro defexclusive/2 (class1 class2)
   `(progn
-     (defmethod subctypep ((ct1 ,class1) (ct2 ,class2)) (values nil t))
-     (defmethod subctypep ((ct1 ,class2) (ct2 ,class1)) (values nil t))
-     (defmethod disjointp ((ct1 ,class1) (ct2 ,class2)) (values t t))
-     (defmethod disjointp ((ct1 ,class2) (ct2 ,class1)) (values t t))))
+     (define-commutative-method subctypep ((ct1 ,class1) (ct2 ,class2))
+       (values nil t))
+     (define-commutative-method disjointp ((ct1 ,class1) (ct2 ,class2))
+       (values t t))
+     (define-commutative-method conjointp ((ct1 ,class1) (ct2 ,class2))
+       (values nil t))))
 
 (defmacro defexclusive (&rest classes)
   `(progn
@@ -19,15 +21,13 @@
              nconc (loop for class2 in rest
                          collect `(defexclusive/2 ,class1 ,class2)))))
 
+(defmacro defexclusives (main &rest classes)
+  `(progn ,@(loop for class in classes
+                  collect `(defexclusive ,main ,class))))
+
 (defexclusive range ccomplex carray charset cfunction)
-(defexclusive/2 cclass range)
-(defexclusive/2 cclass ccomplex)
-(defexclusive/2 cclass charset)
-(defexclusive/2 fpzero cmember)
-(defexclusive/2 fpzero ccomplex)
-(defexclusive/2 fpzero carray)
-(defexclusive/2 fpzero charset)
-(defexclusive/2 fpzero cfunction)
+(defexclusives cclass range ccomplex charset)
+(defexclusives fpzero cmember ccomplex carray charset cfunction)
 
 ;;; cons types are unfortunately ambiguous: (cons (satisfies foo)) MIGHT be
 ;;; bottom "in disguise", and might not be.
@@ -52,17 +52,16 @@
                   ;; That's why this is different from the general method above.
                   (ccons-bottom-p ct1))
                 (defmethod subctypep ((ct1 ,class) (ct2 ccons)) (values nil t))
-                (defmethod disjointp ((ct1 ccons) (ct2 ,class)) (values t t))
-                (defmethod disjointp ((ct1 ,class) (ct2 ccons)) (values t t))))
+                (define-commutative-method disjointp ((ct1 ccons) (ct2 ,class))
+                  (values t t))))
            (consxclusive (&rest classes)
              `(progn ,@(loop for class in classes
                              collect `(consxclusive/1 ,class)))))
   (consxclusive range ccomplex carray charset cfunction fpzero))
 
 (macrolet ((defnonconjoint/2 (c1 c2)
-             `(progn
-                (defmethod conjointp ((ct1 ,c1) (ct2 ,c2)) (values nil t))
-                (defmethod conjointp ((ct1 ,c2) (ct2 ,c1)) (values nil t))))
+             `(define-commutative-method conjointp ((ct1 ,c1) (ct2 ,c2))
+                  (values nil t)))
            (defnonconjoint (&rest classes)
              `(progn
                 ,@(loop for (class1 . rest) on classes
@@ -81,18 +80,12 @@
 (defmethod subctypep ((ct1 ccons) (ct2 cclass))
   (or/tri (ccons-bottom-p ct1) (values (sequence-cclass-p ct2) t)))
 (defmethod subctypep ((ct1 cclass) (ct2 ccons)) (values nil t))
-(defmethod disjointp ((ct1 ccons) (ct2 cclass))
+(define-commutative-method disjointp ((ct1 ccons) (ct2 cclass))
   (or/tri (ccons-bottom-p ct1) (values (not (sequence-cclass-p ct2)) t)))
-(defmethod disjointp ((ct1 cclass) (ct2 ccons))
-  (or/tri (ccons-bottom-p ct2) (values (not (sequence-cclass-p ct1)) t)))
-(defmethod conjoin/2 ((ct1 cclass) (ct2 ccons))
+(define-commutative-method conjoin/2 ((ct1 cclass) (ct2 ccons))
   (if (sequence-cclass-p ct1) ct2 (bot)))
-(defmethod conjoin/2 ((ct1 ccons) (ct2 cclass))
-  (if (sequence-cclass-p ct2) ct1 (bot)))
-(defmethod disjoin/2 ((ct1 cclass) (ct2 ccons))
+(define-commutative-method disjoin/2 ((ct1 cclass) (ct2 ccons))
   (if (sequence-cclass-p ct1) ct1 nil))
-(defmethod disjoin/2 ((ct1 ccons) (ct2 cclass))
-  (if (sequence-cclass-p ct2) ct2 nil))
 (defmethod subtract ((ct1 ccons) (ct2 cclass))
   (if (sequence-cclass-p ct2) (bot) ct1))
 (defmethod subtract ((ct1 cclass) (ct2 ccons))
@@ -104,17 +97,12 @@
                  (and (listp dims) (= (length dims) 1))))
           t))
 (defmethod subctypep ((ct1 cclass) (ct2 carray)) (values nil t))
-(defmethod disjointp ((ct1 carray) (ct2 cclass))
+(define-commutative-method disjointp ((ct1 carray) (ct2 cclass))
   (values (not (and (sequence-cclass-p ct2)
                     (let ((dims (carray-dims ct1)))
                       (or (eq dims '*) (= (length dims) 1)))))
           t))
-(defmethod disjointp ((ct1 cclass) (ct2 carray))
-  (values (not (and (sequence-cclass-p ct1)
-                    (let ((dims (carray-dims ct2)))
-                      (or (eq dims '*) (= (length dims) 1)))))
-          t))
-(defun conjoin-cclass-carray (cclass carray)
+(define-commutative-method conjoin/2 ((cclass cclass) (carray carray))
   (if (sequence-cclass-p cclass)
       (let ((dims (carray-dims carray)))
         (cond ((eq dims '*)
@@ -124,10 +112,6 @@
               ((= (length dims) 1) carray)
               (t (bot))))
       (bot)))
-(defmethod conjoin/2 ((ct1 cclass) (ct2 carray))
-  (conjoin-cclass-carray ct1 ct2))
-(defmethod conjoin/2 ((ct1 carray) (ct2 cclass))
-  (conjoin-cclass-carray ct2 ct1))
 (defmethod subtract ((ct1 cclass) (ct2 carray))
   (if (sequence-cclass-p ct1)
       (let ((dims (carray-dims ct2)))
@@ -153,14 +137,10 @@
   (if (subfunction-cclass-p ct1)
       (if (function-top-p ct2) (values t t) (values nil nil))
       (values nil t)))
-(defmethod conjoin/2 ((ct1 cclass) (ct2 cfunction))
+(define-commutative-method conjoin/2 ((ct1 cclass) (ct2 cfunction))
   (if (subfunction-cclass-p ct1)
       (if (function-top-p ct2) ct1 nil)
       (bot)))
-(defmethod conjoin/2 ((ct1 cfunction) (ct2 cclass))
-  (if (subfunction-cclass-p ct2)
-      (if (function-top-p ct1) ct2 nil)
-      (bot)))
 (defmethod subtract ((ct1 cclass) (ct2 cfunction))
   (if (subfunction-cclass-p ct1)
       (if (function-top-p ct2) (bot) nil)
@@ -228,48 +208,34 @@
 
 ;;; These methods exist so that disjoin-cmember doesn't produce nested
 ;;; disjunctions, e.g. from (or boolean list) => (or (eql t) (or cons null))
-(defun disjoin-cmember-disjunction (cmember disjunction)
+(define-commutative-method disjoin/2 ((cmember cmember) (disjunction disjunction))
   (let* ((scts (junction-ctypes disjunction))
          (non (loop for elem in (cmember-members cmember)
                     unless (loop for sct in scts
-                                   thereis (ctypep elem sct))
+                                 thereis (ctypep elem sct))
                       collect elem)))
     ;; We use disjoin instead of creating a disjunction in case one of our
     ;; disjunction ctypes is another cmember to be merged.
     ;; Inefficient? Probably.
     (apply #'disjoin (apply #'cmember non) scts)))
-(defmethod disjoin/2 ((ct1 cmember) (ct2 disjunction))
-  (disjoin-cmember-disjunction ct1 ct2))
-(defmethod disjoin/2 ((ct1 disjunction) (ct2 cmember))
-  (disjoin-cmember-disjunction ct2 ct1))
 
 ;;; Deal with fpzeros and ranges.
 (defmethod subctypep ((ct1 fpzero) (ct2 range))
   (values (ctypep (fpzero-zero ct1) ct2) t))
 (defmethod subctypep ((ct1 range) (ct2 fpzero)) (values nil t))
 
-(defmethod disjointp ((ct1 fpzero) (ct2 range))
+(define-commutative-method disjointp ((ct1 fpzero) (ct2 range))
   (values (not (ctypep (fpzero-zero ct1) ct2)) t))
-(defmethod disjointp ((ct1 range) (ct2 fpzero))
-  (values (not (ctypep (fpzero-zero ct2) ct1)) t))
 
-(defmethod conjoin/2 ((ct1 fpzero) (ct2 range))
+(define-commutative-method conjoin/2 ((ct1 fpzero) (ct2 range))
   (if (ctypep (fpzero-zero ct1) ct2)
       ct1
       (bot)))
-(defmethod conjoin/2 ((ct1 range) (ct2 fpzero))
-  (if (ctypep (fpzero-zero ct2) ct1)
-      ct2
-      (bot)))
 
-(defmethod disjoin/2 ((ct1 fpzero) (ct2 range))
+(define-commutative-method disjoin/2 ((ct1 fpzero) (ct2 range))
   (if (ctypep (fpzero-zero ct1) ct2)
       ct2
       nil))
-(defmethod disjoin/2 ((ct1 range) (ct2 fpzero))
-  (if (ctypep (fpzero-zero ct2) ct1)
-      ct1
-      nil))
 
 (defmethod subtract ((ct1 fpzero) (ct2 range))
   (if (ctypep (fpzero-zero ct1) ct2)
diff --git a/parse.lisp b/parse.lisp
index 9bb40d7..81dada1 100644
--- a/parse.lisp
+++ b/parse.lisp
@@ -453,14 +453,91 @@
       (destructuring-bind (&optional (et '*) (length '*)) rest
         (array-ctype :either et (list length) env))))
 
+(defvar *parse-extended-types* nil
+  "When `t', `specifier-ctype' will parse extended types. Use
+  `extended-specifier-ctype' instead of using this variable directly.")
+
+(defvar *env* nil
+  "This variable is for `specifier-ctype' to indirectly pass its environment to
+  extended type parsers. Ordinary lambda lists do not allow &environment, but
+  `specifier-ctype' should take an environment. Many functions get around this
+  by using &optional, but this does not work for `define-extended-type' since
+  extended types might already have &optional and may have &rest and &key as
+  well. It is not necessary to use this variable directly because &environment
+  is allowed in `define-extended-type'.")
+
+(defun remove-environment (lambda-list)
+  "Return(0) a new lambda list like LAMBDA-LIST but without the &environment
+  parameter. Return(1) the name of the removed &environment parameter."
+  (let (environment)
+    (values
+     (loop for keys on lambda-list
+           for key = (first keys)
+           if (eq key '&environment) do
+             (setq environment (second keys)
+                   keys (rest keys))
+           else collect key)
+     environment)))
+
+(defmacro define-extended-type (name lambda-list &key (documentation "") simple extended)
+  "Define a type NAME that can be used as a type specifier and as a constructor
+  for a custom ctype. The :simple expander is used by programs that only work
+  with type specifiers like `specifier-ctype'. The :extended expander is used by
+  programs that can take advantage of ctype extensions like
+  `extended-specifier-ctype'.
+
+  SIMPLE is a list of forms that return a type specifier that might not
+  completely represent the custom type.
+
+  EXTENDED is a list of forms that return a ctype that completely represents the
+  custom type.
+
+  Both the SIMPLE and the EXTENDED forms share the parameters of LAMBDA-LIST.
+
+  LAMBDA-LIST is an ordinary lambda list that also allows &environment."
+  (assert simple nil "simple form is required")
+  (assert extended nil "extended form is required")
+  `(progn
+     (deftype ,name ,lambda-list
+       ,documentation
+       ,@simple)
+     (setf (get ',name 'extended-type-parser)
+           ,(multiple-value-bind
+                  (clean-lambda-list env-name) (remove-environment lambda-list)
+              `(lambda ,clean-lambda-list
+                 ,documentation
+                 ,(if env-name
+                      `(symbol-macrolet ((,env-name *env*))
+                         ,@extended)
+                      `(progn ,@extended)))))
+     ',name))
+
 (defun parse (specifier env)
-  (let ((spec (typexpand specifier env)))
-    (etypecase spec
-      (cons (cons-specifier-ctype (car spec) (cdr spec) env))
-      (symbol (or (symbol-specifier-ctype spec env)
-                  (class-specifier-ctype (find-class spec t env) env)))
-      (class (or (symbol-specifier-ctype (class-name spec) env)
-                 (class-specifier-ctype spec env))))))
+  (flet ((parse-symbol (spec)
+           (or (symbol-specifier-ctype spec env)
+               (class-specifier-ctype (find-class spec t env) env)))
+         (parse-class (spec)
+           (or (symbol-specifier-ctype (class-name spec) env))))
+    (if *parse-extended-types*
+        (etypecase specifier
+          (cons (let* ((name (car specifier))
+                       (args (cdr specifier))
+                       (parser (get name 'extended-type-parser)))
+                  (if parser
+                      (let ((*env* env))
+                        (apply parser args))
+                      (cons-specifier-ctype name args env))))
+          (symbol (let ((parser (get specifier 'extended-type-parser)))
+                    (if parser
+                        (let ((*env* env))
+                          (funcall parser))
+                        (parse-symbol specifier))))
+          (class (parse-class specifier)))
+        (let ((spec (typexpand specifier env)))
+          (etypecase spec
+            (cons (cons-specifier-ctype (car spec) (cdr spec) env))
+            (symbol (parse-symbol spec))
+            (class (parse-class spec)))))))
 
 (defun specifier-ctype (specifier &optional env)
   (let ((ct (parse specifier env)))
@@ -474,3 +551,9 @@
         ct
         ;; Treat X as (values X).
         (parse-values-ctype `(,specifier) env))))
+
+(defun extended-specifier-ctype (specifier &optional env)
+  "Return the ctype specified by the possibly extended SPECIFIER."
+  (let ((*parse-extended-types* t))
+    (specifier-ctype specifier env)))
+