From aad815576b3ca69f0b40d806ac249bfeb1a2fb1d Mon Sep 17 00:00:00 2001
From: Douglas Katzman <dougk@google.com>
Date: Sun, 1 Mar 2015 11:00:25 -0500
Subject: [PATCH] Disallow both a :translator and :expander for any type name.

---
 src/code/late-type.lisp           |  5 +++--
 src/compiler/generic/vm-type.lisp | 15 +++++----------
 src/compiler/globaldb.lisp        | 23 +++++++++++++++++++----
 3 files changed, 27 insertions(+), 16 deletions(-)

diff --git a/src/code/late-type.lisp b/src/code/late-type.lisp
index 76c85c7cd..beacd7879 100644
--- a/src/code/late-type.lisp
+++ b/src/code/late-type.lisp
@@ -2269,10 +2269,11 @@ used for a COMPLEX component.~:@>"
 (defmacro !define-float-format (f)
   `(!def-bounded-type ,f float ,f))
 
-(!define-float-format short-float)
+;; (!define-float-format short-float) ; it's a DEFTYPE
 (!define-float-format single-float)
 (!define-float-format double-float)
-(!define-float-format long-float)
+;; long-float support is dead.
+;; (!define-float-format long-float) ; also a DEFTYPE
 
 (defun numeric-types-intersect (type1 type2)
   (declare (type numeric-type type1 type2))
diff --git a/src/compiler/generic/vm-type.lisp b/src/compiler/generic/vm-type.lisp
index 08a9cf4a0..2164d8410 100644
--- a/src/compiler/generic/vm-type.lisp
+++ b/src/compiler/generic/vm-type.lisp
@@ -17,16 +17,11 @@
 ;;;; implementation-dependent DEFTYPEs
 
 ;;; Make DOUBLE-FLOAT a synonym for LONG-FLOAT, SINGLE-FLOAT for
-;;; SHORT-FLOAT. This is expanded before the translator gets a chance,
-;;; so we will get precedence.
-#!-long-float
-(setf (info :type :kind 'long-float) :defined)
-#!-long-float
-(sb!xc:deftype long-float (&optional low high)
-  `(double-float ,low ,high))
-(setf (info :type :kind 'short-float) :defined)
-(sb!xc:deftype short-float (&optional low high)
-  `(single-float ,low ,high))
+;;; SHORT-FLOAT. This is done by way of an "expander", not a "translator".
+;;; !PRECOMPUTE-TYPES will turn their :TYPE :KIND into :PRIMITIVE
+;;; in the target image so that they become not redefinable.
+(sb!xc:deftype long-float (&optional low high) `(double-float ,low ,high))
+(sb!xc:deftype short-float (&optional low high) `(single-float ,low ,high))
 
 ;;; worst-case values for float attributes
 (sb!xc:deftype float-exponent ()
diff --git a/src/compiler/globaldb.lisp b/src/compiler/globaldb.lisp
index b5e63c601..56310e7ba 100644
--- a/src/compiler/globaldb.lisp
+++ b/src/compiler/globaldb.lisp
@@ -602,6 +602,8 @@
 ;;; that are implemented as structures. For PCL classes, that have
 ;;; only been compiled, but not loaded yet, we return
 ;;; :FORTHCOMING-DEFCLASS-TYPE.
+;;; The only major distinction between :PRIMITIVE and :DEFINED
+;;; is how badly the system complains about attempted redefinition.
 (define-info-type (:type :kind)
   :type-spec (member :primitive :defined :instance
                      :forthcoming-defclass-type nil)
@@ -611,13 +613,26 @@
                          (error 'declaration-type-conflict-error
                                 :format-arguments (list name)))))
 
-;;; the expander function for a defined type
-(define-info-type (:type :expander) :type-spec (or function null))
-
 (define-info-type (:type :documentation) :type-spec (or string null))
 
+;;; The expander function for a defined type.
+;;; It returns a type expression, not a CTYPE.
+(define-info-type (:type :expander)
+  :type-spec (or function null)
+  ;; This error is never seen by a user.
+  ;; The user sees "illegal to redefine standard type".
+  :validate-function (lambda (name new-value)
+                       (when (and new-value (info :type :translator name))
+                         (error "Type has a translator"))))
+
 ;;; function that parses type specifiers into CTYPE structures
-(define-info-type (:type :translator) :type-spec (or function null))
+(define-info-type (:type :translator)
+  :type-spec (or function null)
+  ;; This error is never seen by a user. After meta-compile there is no
+  ;; means to define additional types with custom translators.
+  :validate-function (lambda (name new-value)
+                       (when (and new-value (info :type :expander name))
+                         (error "Type has an expander"))))
 
 ;;; If true, then the type coresponding to this name. Note that if
 ;;; this is a built-in class with a translation, then this is the
-- 
2.11.4.GIT