From 2b2252cc8d730004a1c95f227a0024a28b65087c Mon Sep 17 00:00:00 2001 From: Mark Wooding Date: Thu, 26 May 2016 09:26:09 +0100 Subject: [PATCH] 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. --- src/c-types-impl.lisp | 29 ++++++++++++++++++++--------- 1 file changed, 20 insertions(+), 9 deletions(-) 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 @@ (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 @@ (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. -- 2.11.0