src/c-types-impl.lisp (make-or-intern-c-type): Pull out useful function.

There's a recurring pattern whether a subtype is interned and using that
to decide whether to intern the derived type.  Pull it out into its own
function.  We'll want it more later; but even now it simplifies a couple
of call sites.

diff --git a/src/c-types-impl.lisp b/src/c-types-impl.lisp
index 9257bf232c8de6da37a6cb4968f3c24e155dd767..e4e9587411a33b3a8232aecfbbf4b48f36a1af32 100644 (file)
--- a/src/c-types-impl.lisp
+++ b/src/c-types-impl.lisp
@@ -66,12 +66,26 @@ (defun check-type-intern-map ()
                 (assert (gethash k map))))
             *c-type-intern-map*)))
 
+(defun make-or-intern-c-type (new-type-class base-types &rest initargs)
+  "Return a possibly-new instance of NEW-TYPE-CLASS with the given INITARGS.
+
+   If all of the BASE-TYPES are interned, then use `intern-c-type' to
+   construct the new type; otherwise just make a new one with
+   `make-instance'.  BASE-TYPES may be a singleton type, or a sequence of
+   types."
+  (apply (if (if (typep base-types 'sequence)
+                (every (lambda (type)
+                         (gethash type *c-type-intern-map*))
+                       base-types)
+                (gethash base-types *c-type-intern-map*))
+            #'intern-c-type #'make-instance)
+        new-type-class
+        initargs))
+
 (defmethod qualify-c-type ((type qualifiable-c-type) qualifiers)
   (let ((initargs (instance-initargs type)))
     (remf initargs :qualifiers)
-    (apply (if (gethash type *c-type-intern-map*)
-              #'intern-c-type #'make-instance)
-          (class-of type)
+    (apply #'make-or-intern-c-type (class-of type) type
           :qualifiers (canonify-qualifiers
                        (append qualifiers (c-type-qualifiers type)))
           initargs)))
@@ -278,12 +292,9 @@ (defclass c-pointer-type (qualifiable-c-type)
 (export 'make-pointer-type)
 (defun make-pointer-type (subtype &optional qualifiers)
   "Return a (maybe distinguished) pointer type."
-  (let ((canonical (canonify-qualifiers qualifiers)))
-    (funcall (if (gethash subtype *c-type-intern-map*)
-                #'intern-c-type #'make-instance)
-            'c-pointer-type
-            :subtype subtype
-            :qualifiers canonical)))
+  (make-or-intern-c-type 'c-pointer-type subtype
+                        :subtype subtype
+                        :qualifiers (canonify-qualifiers qualifiers)))
 
 ;; Comparison protocol.