From 49319a8c7f3527b0d452b8f07bdabe02283e8ff7 Mon Sep 17 00:00:00 2001
From: Paul Khuong <pvk@pvk.ca>
Date: Tue, 12 Oct 2010 04:46:02 +0000
Subject: [PATCH] 1.0.43.44: New type method: TYPE-SINGLETON-P

 * The new type method is used to Determine whether a type is inhabited
   by exactly one object.  If so, it returns and the object.  Otherwise,
   it returns NIL, NIL.

 * It is only defined for MEMBER, CHARACTER-SET and NUMERIC -TYPEs so
   far.

 * The default is to always return NIL, NIL.
---
 package-data-list.lisp-expr |    1 +
 src/code/late-type.lisp     |   38 ++++++++++++++++++++++++++++++++++++++
 src/code/type-class.lisp    |   10 ++++++++--
 version.lisp-expr           |    2 +-
 4 files changed, 48 insertions(+), 3 deletions(-)

diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr
index 5873842..9d51a31 100644
--- a/package-data-list.lisp-expr
+++ b/package-data-list.lisp-expr
@@ -1659,6 +1659,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries."
                "TYPE-*-TO-T"
                "TYPE-DIFFERENCE" "TYPE-EXPAND" "TYPE-INTERSECTION"
                "TYPE-INTERSECTION2" "TYPE-APPROX-INTERSECTION2"
+               "TYPE-SINGLETON-P"
                "TYPE-SINGLE-VALUE-P" "TYPE-SPECIFIER" "TYPE-UNION"
                "TYPE/=" "TYPE=" "TYPES-EQUAL-OR-INTERSECT"
                "UNBOUND-SYMBOL-ERROR" "UNBOXED-ARRAY"
diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index 3953c54..16b605d 100644
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -978,6 +978,20 @@
   (declare (type ctype type))
   (funcall (type-class-negate (type-class-info type)) type))
 
+(defun-cached (type-singleton-p :hash-function (lambda (type)
+                                              (logand (type-hash-value type)
+                                                      #xff))
+                             :hash-bits 8
+                             :values 2
+                             :default (values nil t)
+                             :init-wrapper !cold-init-forms)
+              ((type eq))
+  (declare (type ctype type))
+  (let ((function (type-class-singleton-p (type-class-info type))))
+    (if function
+        (funcall function type)
+        (values nil nil))))
+
 ;;; (VALUES-SPECIFIER-TYPE and SPECIFIER-TYPE moved from here to
 ;;; early-type.lisp by WHN ca. 19990201.)
 
@@ -1710,6 +1724,17 @@
          (aver (eq base+bounds 'real))
          'number)))))
 
+(!define-type-method (number :singleton-p) (type)
+  (let ((low  (numeric-type-low  type))
+        (high (numeric-type-high type)))
+    (if (and low
+             (eql low high)
+             (eql (numeric-type-complexp type) :real)
+             (member (numeric-type-class type) '(integer rational
+                                                 #!-sb-xc-host float)))
+        (values t (numeric-type-low type))
+        (values nil nil))))
+
 ;;; Return true if X is "less than or equal" to Y, taking open bounds
 ;;; into consideration. CLOSED is the predicate used to test the bound
 ;;; on a closed interval (e.g. <=), and OPEN is the predicate used on
@@ -2656,6 +2681,11 @@ used for a COMPLEX component.~:@>"
       ((type= type (specifier-type 'standard-char)) 'standard-char)
       (t `(member ,@members)))))
 
+(!define-type-method (member :singleton-p) (type)
+  (if (eql 1 (member-type-size type))
+      (values t (first (member-type-members type)))
+      (values nil nil)))
+
 (!define-type-method (member :simple-subtypep) (type1 type2)
    (values (and (xset-subset-p (member-type-xset type1)
                                  (member-type-xset type2))
@@ -3271,6 +3301,14 @@ used for a COMPLEX component.~:@>"
                          nconc (loop for code from low upto high
                                      collect (sb!xc:code-char code))))))))
 
+(!define-type-method (character-set :singleton-p) (type)
+  (let* ((pairs (character-set-type-pairs type))
+         (pair  (first pairs)))
+    (if (and (typep pairs '(cons t null))
+             (eql (car pair) (cdr pair)))
+        (values t (code-char (car pair)))
+        (values nil nil))))
+
 (!define-type-method (character-set :simple-=) (type1 type2)
   (let ((pairs1 (character-set-type-pairs type1))
        (pairs2 (character-set-type-pairs type2)))
diff --git a/src/code/type-class.lisp b/src/code/type-class.lisp
index 0a1a5b5..0a48bb4 100644
--- a/src/code/type-class.lisp
+++ b/src/code/type-class.lisp
@@ -90,7 +90,12 @@
   ;; a function which returns a Common Lisp type specifier
   ;; representing this type
   (unparse #'must-supply-this :type function)
-
+  ;; a function which returns T if the CTYPE is inhabited by a single
+  ;; object and, as a value, the object.  Otherwise, returns NIL, NIL.
+  ;; The default case (NIL) is interpreted as a function that always
+  ;; returns NIL, NIL.
+  (singleton-p nil :type (or function null))
+  
   #|
   Not used, and not really right. Probably we want a TYPE= alist for the
   unary operations, since there are lots of interesting unary predicates that
@@ -123,7 +128,8 @@
       (:simple-= . type-class-simple-=)
       (:complex-= . type-class-complex-=)
       (:negate . type-class-negate)
-      (:unparse . type-class-unparse))))
+      (:unparse . type-class-unparse)
+      (:singleton-p . type-class-singleton-p))))
 
 (declaim (ftype (function (type-class) type-class) copy-type-class-coldly))
 (eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
diff --git a/version.lisp-expr b/version.lisp-expr
index 4caedee..602b4ef 100644
--- a/version.lisp-expr
+++ b/version.lisp-expr
@@ -17,4 +17,4 @@
 ;;; checkins which aren't released. (And occasionally for internal
 ;;; versions, especially for internal versions off the main CVS
 ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"1.0.43.43"
+"1.0.43.44"
-- 
1.7.10.4