From: Mark Wooding <mdw@distorted.org.uk>
Date: Thu, 26 May 2016 08:26:09 +0000 (+0100)
Subject: src/c-types-impl.lisp (make-or-intern-c-type): Pull out useful function.
X-Git-Url: https://www.chiark.greenend.org.uk/ucgi/~mdw/git/sod/commitdiff_plain/2b2252cc8d730004a1c95f227a0024a28b65087c?ds=inline

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 9257bf2..e4e9587 100644
--- 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.