From 053998a5e2387731dc54350f4e8f9a1578cdc814 Mon Sep 17 00:00:00 2001 From: Stas Boukarev Date: Wed, 20 Dec 2017 01:15:04 +0300 Subject: [PATCH] CTYPEP: handle (CONS/ARRAY unknown-type). Don't try to check such types at compile time. --- src/code/target-type.lisp | 18 +++++++++++++++--- tests/compiler-2.pure.lisp | 10 ++++++++++ 2 files changed, 25 insertions(+), 3 deletions(-) diff --git a/src/code/target-type.lisp b/src/code/target-type.lisp index ba9d4f5e8..8a32db499 100644 --- a/src/code/target-type.lisp +++ b/src/code/target-type.lisp @@ -32,12 +32,24 @@ ((or numeric-type named-type member-type - array-type character-set-type built-in-classoid - cons-type #!+sb-simd-pack simd-pack-type) - (values (%%typep obj type) t)) + (values (%%typep obj type) + t)) + (array-type + (if (contains-unknown-type-p type) + (values nil nil) + (values (%%typep obj type) t))) + (cons-type + ;; Do not use %%TYPEP because of SATISFIES + (if (consp obj) + (multiple-value-bind (typep valid) + (ctypep (car obj) (cons-type-car-type type)) + (if typep + (ctypep (cdr obj) (cons-type-cdr-type type)) + (values nil valid))) + (values nil t))) (classoid (if (if (csubtypep type (specifier-type 'function)) (funcallable-instance-p obj) diff --git a/tests/compiler-2.pure.lisp b/tests/compiler-2.pure.lisp index 251777fec..05b47d83e 100644 --- a/tests/compiler-2.pure.lisp +++ b/tests/compiler-2.pure.lisp @@ -850,3 +850,13 @@ (checked-compile `(lambda () (labels ((%f ())) (%f #'%f))) :allow-warnings t)))) + +(with-test (:name (:ctypep :hairy-types)) + (checked-compile + `(lambda () + (the (cons (satisfies error)) '("a")))) + (assert + (nth-value 3 + (checked-compile + `(lambda () (the (array abc) #())) + :allow-style-warnings t)))) -- 2.11.4.GIT