From c67b115f938ff611f58e67d98bc9df19fbced8dd Mon Sep 17 00:00:00 2001 From: Bike Date: Wed, 3 Apr 2024 17:19:40 -0400 Subject: [PATCH] Fix TYPEP SEQUENCE for extended sequences sssssorta. this is very messy. and it doesn't fix subtypep. and it breaks (subtypep '(cons foo) 'sequence). --- src/lisp/kernel/clos/boot.lisp | 5 +++++ src/lisp/kernel/cmp/opt/opt-type.lisp | 4 +++- src/lisp/kernel/lsp/predlib.lisp | 6 +++--- 3 files changed, 11 insertions(+), 4 deletions(-) diff --git a/src/lisp/kernel/clos/boot.lisp b/src/lisp/kernel/clos/boot.lisp index 2d340a692b..f08ef097aa 100644 --- a/src/lisp/kernel/clos/boot.lisp +++ b/src/lisp/kernel/clos/boot.lisp @@ -175,6 +175,11 @@ (setq +the-std-class+ (find-class 'std-class nil)) (setq +the-funcallable-standard-class+ (find-class 'funcallable-standard-class nil))) + +;; Undefine the SEQUENCE type expansion, which does not account +;; for extended sequences. Redefining SEQUENCE like this is a KLUDGE. +(setf (ext:type-expander 'sequence) nil) + ;; ;; Finalize ;; diff --git a/src/lisp/kernel/cmp/opt/opt-type.lisp b/src/lisp/kernel/cmp/opt/opt-type.lisp index 49e2ee55db..59a246b3a8 100644 --- a/src/lisp/kernel/cmp/opt/opt-type.lisp +++ b/src/lisp/kernel/cmp/opt/opt-type.lisp @@ -361,7 +361,9 @@ et (upgraded-array-element-type et env))))) ((sequence) - `(or (listp object) (vectorp object))) + `(or (listp object) (vectorp object) + (subclassp (class-of object) + (load-time-value (find-class 'sequence))))) ((standard-char) `(and (characterp object) (standard-char-p object))) ;; NOTE: Probably won't actually occur, due to normalization. diff --git a/src/lisp/kernel/lsp/predlib.lisp b/src/lisp/kernel/lsp/predlib.lisp index 3d9d41ce59..a4c2bae1b0 100644 --- a/src/lisp/kernel/lsp/predlib.lisp +++ b/src/lisp/kernel/lsp/predlib.lisp @@ -527,7 +527,9 @@ Returns T if X belongs to TYPE; NIL otherwise." ;; Note that if you decide to change this, you'll need to alter the ;; compiler macro (in cmp/opt-type.lisp) as well. (COMPLEX (complexp object)) - (SEQUENCE (or (listp object) (vectorp object))) + (SEQUENCE (or (listp object) (vectorp object) + (si:subclassp (class-of object) + (find-class 'sequence)))) (CONS (and (consp object) (or (endp i) (let ((car-type (first i))) @@ -1223,8 +1225,6 @@ if not possible." (core:simple-character-string (SIMPLE-ARRAY CHARACTER (*))) (BIT-VECTOR (ARRAY BIT (*))) - (SEQUENCE (OR CONS (MEMBER NIL) (ARRAY * (*)))) - (HASH-TABLE) (PATHNAME) (LOGICAL-PATHNAME NIL PATHNAME)