Actually fix alien-fun-type-hashset

Doesn't work to hash-cons if the leaves aren't hash-consed

src/code/alieneval.lisp

@@ -1551,17 +1551,40 @@
 ;;; but then it doesn't know about hash-consing.
 #-sb-xc-host
 (defun make-type-load-form (x env)
-  (if (acyclic-type-p x)
+  ;; For now this deals with only a few categories of types:
-      ;; hash-cons it
+  ;; 1) Atoms INTEGER, BOOLEAN, SYSTEM-AREA-POINTER, C-STRING, FLOAT
-      `(make-alien-fun-type :convention ',(alien-fun-type-convention x)
+  ;;    but without whacky redefining behavior - so no ENUM.
-                            :result-type ,(alien-fun-type-result-type x)
+  ;; 2) FUN-TYPE
-                            :arg-types ',(alien-fun-type-arg-types x)
+  (cond
-                            :varargs ,(alien-fun-type-varargs x))
+    ((and (alien-integer-type-p x) (not (alien-enum-type-p x)))
-      ;; there is some cycle involving this type
+     (if (alien-boolean-type-p x)
-      (make-load-form-saving-slots
+         `(make-alien-boolean-type :bits ,(alien-boolean-type-bits x)
-       x
+                                   :signed nil)
-       :slot-names '(hash bits alignment result-type arg-types varargs convention)
+         `(make-alien-integer-type :bits ,(alien-integer-type-bits x)
-       :environment env)))
+                                   :signed ,(alien-integer-type-signed x))))
+    ((alien-float-type-p x)
+     (ecase (alien-float-type-type x)
+       (single-float `(parse-alien-type 'single-float nil))
+       (double-float `(parse-alien-type 'double-float nil))))
+    ((eq (sb-kernel:%instance-layout x)
+         #.(sb-kernel:find-layout 'alien-system-area-pointer-type)) ; not its subtypes
+     `(parse-alien-type 'system-area-pointer nil))
+    ((alien-c-string-type-p x)
+     `(load-alien-c-string-type ',(alien-c-string-type-element-type x)
+                                ',(alien-c-string-type-external-format x)
+                                ',(alien-c-string-type-not-null x)))
+    ((alien-fun-type-p x)
+     (if (acyclic-type-p x)
+         ;; hash-cons it
+         `(make-alien-fun-type :convention ',(alien-fun-type-convention x)
+                               :result-type ,(alien-fun-type-result-type x)
+                               :arg-types ',(alien-fun-type-arg-types x)
+                               :varargs ,(alien-fun-type-varargs x))
+         ;; there is some cycle involving this type
+         (make-load-form-saving-slots
+          x
+          :slot-names '(hash bits alignment result-type arg-types varargs convention)
+          :environment env)))))
 
 (defun show-alien-type-caches ()
   (dolist (var *alien-type-hashsets*)

src/code/c-call.lisp

@@ -11,16 +11,19 @@
 
 ;;;; C string support.
 
-(define-alien-type-translator c-string
+(defun load-alien-c-string-type (element-type external-format not-null)
-    (&key (external-format :default)
-          (element-type 'character)
-          (not-null nil))
   (make-alien-c-string-type
    :to (parse-alien-type 'char (sb-kernel:make-null-lexenv))
    :element-type element-type
    :external-format external-format
    :not-null not-null))
 
+(define-alien-type-translator c-string
+    (&key (external-format :default)
+          (element-type 'character)
+          (not-null nil))
+  (load-alien-c-string-type element-type external-format not-null))
+
 (defun c-string-external-format (type)
   (let ((external-format (alien-c-string-type-external-format type)))
     (if (eq external-format :default)

src/pcl/env.lisp

@@ -65,7 +65,8 @@
                 mf)
              plist ,arg-info simple-next-method-call t)
            source-loc))))))
-(!install-cross-compiled-methods 'make-load-form :except '(wrapper))
+(!install-cross-compiled-methods 'make-load-form
+                                 :except '(wrapper sb-alien-internals:alien-type))
 
 (defmethod make-load-form ((class class) &optional env)
   ;; FIXME: should we not instead pass ENV to FIND-CLASS?  Probably
@@ -85,8 +86,9 @@
              (wrapper-classoid object)))
     `(classoid-wrapper (find-classoid ',pname))))
 
-(defmethod make-load-form ((object sb-alien-internals:alien-fun-type) &optional env)
+(defmethod make-load-form ((object sb-alien-internals:alien-type) &optional env)
-  (sb-alien::make-type-load-form object env))
+  (or (sb-alien::make-type-load-form object env)
+      (make-load-form-saving-slots object :environment env)))
 
 ;; FIXME: this seems wrong. NO-APPLICABLE-METHOD should be signaled.
 (defun dont-know-how-to-dump (object)

tests/alientype.pure-cload.lisp

@@ -0,0 +1,26 @@
+(defparameter *bool8type*
+  #.(sb-alien-internals:parse-alien-type '(boolean 8) nil))
+(defparameter *s13type*
+  #.(sb-alien-internals:parse-alien-type '(signed 13) nil))
+(defparameter *cstrtype*
+  (sb-alien-internals:parse-alien-type
+   '(c-string :external-format :church-latin ; we don't validate this?
+              :element-type base-char
+              :not-null t)
+   nil))
+
+(with-test (:name :hash-cons-alien-type-atoms)
+  ;; restored as the right metatype
+  (assert (sb-alien-internals:alien-boolean-type-p *bool8type*))
+  (assert (eq *bool8type* ; and re-parses to the identical object
+              (sb-alien-internals:parse-alien-type '(boolean 8) nil)))
+
+  (assert (eq *s13type*
+              (sb-alien-internals:parse-alien-type '(signed 13) nil)))
+
+  (assert (eq *cstrtype*
+              (sb-alien-internals:parse-alien-type
+               '(c-string :external-format :church-latin
+                          :element-type base-char
+                          :not-null t)
+               nil))))