From 12332bbfc768de7eef1692c54d5d38a87687992f Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Wed, 24 Jan 2024 08:35:42 +0000 Subject: [PATCH] Restore funcallable sequences Absence of tests meant that a prior simplification (revision 17945c81f96b406d3cbc6bfd73c0090e6ce92c6b) removed the ability to inherit simultaneously from SEQUENCE and FUNCTION, breaking example code in the extensible sequences ILC paper. Restore this, attempting to explain various things about the current system in response to a comment, and include tests to hopefully preserve subclassing of FUNCTION, SEQUENCE and STREAM independently of each other. Additionally fix the COERCE transform to transform into sequence coercion if the type argument names an extended sequence class. Fixes lp#2050088 --- NEWS | 5 ++ src/code/class.lisp | 46 ++++++++------ src/code/coerce.lisp | 18 ++++-- src/cold/exports.lisp | 1 + src/compiler/typetran.lisp | 5 ++ tests/extended-sequences.impure.lisp | 83 ++++++++++++++++++++++++ tests/mop-35.impure.lisp | 95 ++++++++++++++++++++++++++++ 7 files changed, 226 insertions(+), 27 deletions(-) create mode 100644 tests/mop-35.impure.lisp diff --git a/NEWS b/NEWS index 921ae8554..862bc089a 100644 --- a/NEWS +++ b/NEWS @@ -1,5 +1,10 @@ ;;;; -*- coding: utf-8; fill-column: 78 -*- +changes relative to sbcl-2.4.1: + * bug fix: restore the ability to inherit from both SEQUENCE and + SB-MOP:FUNCALLABLE-STANDARD-OBJECT. (lp#2050088, reported by Christophe + Junke) + changes in sbcl-2.4.1 relative to sbcl-2.4.0: * enhancement: compact instance headers are partially supported with the mark-region parallel garbage collector. diff --git a/src/code/class.lisp b/src/code/class.lisp index e03a0e958..261c802ec 100644 --- a/src/code/class.lisp +++ b/src/code/class.lisp @@ -442,24 +442,30 @@ between the ~A definition and the ~A definition" ;;; Arrange the inherited layouts to appear at their expected depth, ;;; ensuring that hierarchical type tests succeed. Layouts with -;;; DEPTHOID >= 0 (i.e. hierarchical classes) are placed first, -;;; at exactly that index in the INHERITS vector. Then, non-hierarchical +;;; DEPTHOID >= 0 (i.e. hierarchical classes) are placed first, at +;;; exactly that index in the INHERITS vector. Then, non-hierarchical ;;; layouts are placed in remaining elements. Then, any still-empty -;;; elements are filled with their successors, ensuring that each -;;; element contains a valid layout. +;;; elements are filled with their successors, as might happen when +;;; layouts corresponding to classes which can be multiply-inherited +;;; but aren't, ensuring that each element contains a valid layout. +;;; +;;; KLUDGE: when constructing the built in classoids themselves, +;;; ORDER-LAYOUT-INHERITS is not called. This leads to the +;;; layout-inherits of those built-in-classoids not following the +;;; rules (for example, the layout-inherits of FILE-STREAM is of +;;; length 2, containing just the layouts of T and STREAM; STREAM is +;;; defined to be at depth 3, so why don't we see problems? For two +;;; reasons, I think; firstly, type checks of the classoids at +;;; specified fixed depth is actually handled through special bits in +;;; the layout hash, rather than the previous implementation of +;;; indexing the layout-inherits vector at the known depth and +;;; checking for EQLity. Secondly, the built-in-classoids with this +;;; property (a specified depth with space for multiple-inheritance) +;;; are all abstract; even if we were still indexing the +;;; layout-inherits vector, it's not possible to create a direct +;;; instance of FILE-STREAM / STRING-STREAM / SEQUENCE in order to +;;; (possibly) get the wrong answer from TYPEP. -- CSR, 2024-01-24 ;;; -;;; *** FIXME *** the preceding comment seems dubious, and I'm not sure whether -;;; to fix the code or the comment or both. The code works as-is, but is too hairy. -;;; I fail to see how "still-empty" elements can exist after filling in mandatory -;;; elements. It seems to anticipate being able to create a type whose INHERITS vector -;;; length exceeds depthoid, or, say, a type at depthoid 5 which inherits STREAM but -;;; might lack an entry at depth index 1 for example. As to why I think the comment -;;; is false: FILE-STREAM and STRING-STREAM each have depthoid 4, but their INHERITS -;;; vector has length 2. So they don't store elements that would be at index 2 and 3. -;;; Length less than depthoid is opposite of what the fill-in logic supports. -;;; How, in practice, could a user achieve such weird states as need this logic? -;;; If impossible, then simplify it. - ;;; This reordering may destroy CPL ordering, so the inherits should ;;; not be read as being in CPL order. (defun order-layout-inherits (layouts) @@ -1137,7 +1143,7 @@ between the ~A definition and the ~A definition" (sequence :translation (or cons (member nil) vector extended-sequence) :state :read-only - :depth 1) + :depth 2) (vector :translation vector :codes (,sb-vm:complex-vector-widetag) :direct-superclasses (array sequence) @@ -1263,16 +1269,16 @@ between the ~A definition and the ~A definition" (stream :predicate streamp :state :read-only - :depth 2) + :depth 3) (file-stream :predicate file-stream-p :state :read-only - :depth 4 + :depth 5 :inherits (stream)) (string-stream :predicate string-stream-p :state :read-only - :depth 4 + :depth 5 :inherits (stream)) ,@(loop for x across sb-vm:*specialized-array-element-type-properties* unless (member (sb-vm:saetp-specifier x) '(t character base-char nil bit)) diff --git a/src/code/coerce.lisp b/src/code/coerce.lisp index dfe0474c9..fadb9a0a3 100644 --- a/src/code/coerce.lisp +++ b/src/code/coerce.lisp @@ -59,6 +59,12 @@ (declaim (inline coerce-to-list)) (declaim (inline coerce-to-vector)) +(defun coerce-to-extended-sequence (object class) + (let ((prototype (sb-mop:class-prototype + (sb-pcl:ensure-class-finalized class)))) + (sb-sequence:make-sequence-like + prototype (length object) :initial-contents object))) + (defun coerce-to-fun (object) ;; (Unlike the other COERCE-TO-FOOs, this one isn't inline, because ;; it's so big and because optimizing away the outer ETYPECASE @@ -233,13 +239,11 @@ (sequence (sequence-to-vector* object output-type-spec)) (t (coerce-error)))) - ((and (csubtypep type (specifier-type 'sequence)) - (find-class output-type-spec nil)) - (let ((prototype (sb-mop:class-prototype - (sb-pcl:ensure-class-finalized - (find-class output-type-spec))))) - (sb-sequence:make-sequence-like - prototype (length object) :initial-contents object))) + ((csubtypep type (specifier-type 'sequence)) + (let ((class (find-class output-type-spec nil))) + (if class + (coerce-to-extended-sequence object class) + (coerce-error)))) ((csubtypep type (specifier-type 'function)) (coerce-to-fun object)) (t diff --git a/src/cold/exports.lisp b/src/cold/exports.lisp index 1e8b38483..21d400058 100644 --- a/src/cold/exports.lisp +++ b/src/cold/exports.lisp @@ -2034,6 +2034,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries.") "CODE-INSTRUCTIONS" "CODE-N-UNBOXED-DATA-BYTES" "CODE-OBJECT-SIZE" "CODE-TRAILER-REF" "COERCE-SYMBOL-TO-FUN" + "COERCE-TO-EXTENDED-SEQUENCE" "COERCE-TO-FUN" "COERCE-TO-LEXENV" "COERCE-TO-LIST" "COERCE-TO-VALUES" "COERCE-TO-VECTOR" "COMPLEX-DOUBLE-FLOAT" "COMPLEX-DOUBLE-FLOAT-P" diff --git a/src/compiler/typetran.lisp b/src/compiler/typetran.lisp index 1bd97d578..3b8c42fac 100644 --- a/src/compiler/typetran.lisp +++ b/src/compiler/typetran.lisp @@ -1641,6 +1641,11 @@ `(make-array ,dimension ,@specialization :initial-contents x)))))))) ((type= tspec (specifier-type 'list)) `(coerce-to-list x)) + ((csubtypep tspec (specifier-type 'extended-sequence)) + (let ((class (and (symbolp tval) (find-class tval nil)))) + (if (null class) + (give-up-ir1-transform) + `(coerce-to-extended-sequence x (load-time-value (find-class ',tval) t))))) ((csubtypep tspec (specifier-type 'function)) (if (csubtypep (lvar-type x) (specifier-type 'symbol)) `(coerce-symbol-to-fun x) diff --git a/tests/extended-sequences.impure.lisp b/tests/extended-sequences.impure.lisp index de6a52731..eaa5673db 100644 --- a/tests/extended-sequences.impure.lisp +++ b/tests/extended-sequences.impure.lisp @@ -161,3 +161,86 @@ (let ((position (read-sequence sequence stream :start 1 :end 3))) (assert (eql 3 position)) (assert (equal '(#\a #\w #\x #\d) (coerce sequence 'list))))))) + +;;; example code from "User-extensible sequences in Common Lisp" +;;; (Rhodes, 2007) + +(defclass queue (sequence standard-object) + ((%data :accessor %queue-data) (%pointer :accessor %queue-pointer))) +(defmethod initialize-instance :after ((o queue) &key) + (let ((head (list nil))) + (setf (%queue-data o) head (%queue-pointer o) head))) +(defgeneric enqueue (data queue) + (:argument-precedence-order queue data) + (:method (data (o queue)) + (setf (cdr (%queue-pointer o)) (list data) (%queue-pointer o) (cdr (%queue-pointer o))) + o)) +(defgeneric dequeue (queue) + (:method ((o queue)) + (prog1 (cadr (%queue-data o)) + (setf (cdr (%queue-data o)) (cddr (%queue-data o)))))) + +(defclass funcallable-queue (queue sb-mop:funcallable-standard-object) + () + (:metaclass sb-mop:funcallable-standard-class)) +(defmethod initialize-instance :after ((o funcallable-queue) &key) + (flet ((fun (&optional (new nil new-p)) (if new-p (enqueue new o) (dequeue o)))) + (sb-mop:set-funcallable-instance-function o #'fun))) + +(defmethod sequence:length ((o queue)) (length (cdr (%queue-data o)))) +(defmethod sequence:elt ((o queue) index) (elt (cdr (%queue-data o)) index)) +(defmethod (setf sequence:elt) (new-value (o queue) index) (setf (elt (cdr (%queue-data o)) index) new-value)) +(defmethod sequence:make-sequence-like ((o queue) length &key (initial-element nil iep) (initial-contents nil icp)) + (let ((result (make-instance (class-of o)))) + (cond + ((and iep icp) + (error "supplied both ~S and ~S to ~S" :initial-element :initial-contents 'make-sequence-like)) + (icp (unless (= (length initial-contents) length) + (error "length mismatch in ~S" 'make-sequence-like)) + (setf (cdr (%queue-data result)) (coerce initial-contents 'list) + (%queue-pointer result) (last (%queue-data result)))) + (t (setf (cdr (%queue-data result)) (make-list length :initial-element initial-element) + (%queue-pointer result) (last (%queue-data result))))) + result)) +(defmethod sequence:adjust-sequence ((o queue) length &key initial-element (initial-contents nil icp)) + (cond + ((= length 0) + (setf (cdr (%queue-data o)) nil (%queue-pointer o) (%queue-data o))) + (t (sequence:adjust-sequence (%queue-data o) (1+ length) :initial-element initial-element) + (setf (%queue-pointer o) (last (%queue-data o))) + (when icp (replace (%queue-data o) initial-contents :start1 1)) o))) +(defmethod sequence:make-simple-sequence-iterator ((q queue) &rest args &key from-end start end) + (declare (ignore from-end start end)) + (apply #'sequence:make-simple-sequence-iterator (cdr (%queue-data q)) args)) +(defmethod sequence:iterator-step ((q queue) iterator from-end) + (sequence:iterator-step (cdr (%queue-data q)) iterator from-end)) +(defmethod sequence:iterator-endp ((q queue) iterator limit from-end) + (sequence:iterator-endp (cdr (%queue-data q)) iterator limit from-end)) +(defmethod sequence:iterator-element ((q queue) iterator) + (sequence:iterator-element (cdr (%queue-data q)) iterator)) +(defmethod (setf sequence:iterator-element) (new-value (q queue) iterator) + (setf (sequence:iterator-element (cdr (%queue-data q)) iterator) new-value)) +(defmethod sequence:iterator-index ((q queue) iterator) + (sequence:iterator-index (cdr (%queue-data q)) iterator)) +(defmethod sequence:iterator-copy ((q queue) iterator) + (sequence:iterator-copy (cdr (%queue-data q)) iterator)) + +(with-test (:name (:ilc2007 :fig4a)) + (assert (= (length (coerce '(1 2 3 4) 'queue)) 4))) +(with-test (:name (:ilc2007 :fig4b)) + (assert (= (count 1 (coerce '(1 2 3) 'queue)) 1))) +(with-test (:name (:ilc2007 :fig4c)) + (let ((result (remove-if-not #'oddp (coerce '(1 2 3) 'funcallable-queue)))) + (assert (typep result 'funcallable-queue)) + (assert (eql (type-of result) 'funcallable-queue)) + (assert (= (length result) 2)) + (assert (= (funcall result) 1)) + (assert (= (funcall result) 3)) + (assert (= (length result) 0)))) +(with-test (:name (:ilc2007 :fig4d)) + (let ((result (remove-duplicates (coerce '(1 2 3 4 5) 'queue) :end 4 + :key #'oddp :from-end t))) + (assert (typep result 'queue)) + (assert (eql (type-of result) 'queue)) + (assert (= (length result) 3)) + (assert (equal (coerce result 'list) '(1 2 5))))) diff --git a/tests/mop-35.impure.lisp b/tests/mop-35.impure.lisp new file mode 100644 index 000000000..2b7eef9e4 --- /dev/null +++ b/tests/mop-35.impure.lisp @@ -0,0 +1,95 @@ +;;;; Constructing and instantiating subclasses of system classes + +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. +;;;; +;;;; While most of SBCL is derived from the CMU CL system, the test +;;;; files (like this one) were written from scratch after the fork +;;;; from CMU CL. +;;;; +;;;; This software is in the public domain and is provided with +;;;; absolutely no warranty. See the COPYING and CREDITS files for +;;;; more information. + +(defmacro assert-subtype (class type) + `(progn + (assert-tri-eq t t (subtypep ',class ',type)) + (assert-instance-type ,class ,type))) + +(defmacro assert-instance-type (class type) + `(flet ((compiled (x) (typep x ',type)) + (evaled (x y) (typep x (opaque-identity y)))) + (assert (typep (make-instance ',class) ',type)) + (assert (compiled (make-instance ',class))) + (assert (evaled (make-instance ',class) ',type)))) + +(defmacro assert-callable (class) + `(let ((i (make-instance ',class))) + (sb-mop:set-funcallable-instance-function i (lambda (x) (1+ x))) + (assert (= (funcall i 51) 52)))) + +(macrolet ((test (stype) + (let ((sname (intern (concatenate 'string "%" (symbol-name stype)))) + (fsname (intern (concatenate 'string "%F" (symbol-name stype))))) + `(progn + (defclass ,sname (,stype standard-object) + ()) + (with-test (:name (,stype standard-object)) + (assert-subtype ,sname ,stype) + (assert-instance-type ,sname (not function)) + (assert-instance-type ,sname (not sequence))) + + (defclass ,fsname (,stype sb-mop:funcallable-standard-object) + () + (:metaclass sb-mop:funcallable-standard-class)) + (with-test (:name (,stype function type)) + (assert-subtype ,fsname ,stype) + (assert-subtype ,fsname function) + (assert-instance-type ,fsname (not sequence))) + (with-test (:name (,stype function funcall)) + (assert-callable ,fsname)))))) + (test stream) + (test file-stream) + (test string-stream)) + +(defclass %sequence (sequence standard-object) + ()) +(with-test (:name (sequence standard-object)) + (assert-subtype %sequence sequence) + (assert-instance-type %sequence (not function)) + (assert-instance-type %sequence (not stream))) + +(defclass %fsequence (sequence sb-mop:funcallable-standard-object) + () + (:metaclass sb-mop:funcallable-standard-class)) +(with-test (:name (sequence function type)) + (assert-subtype %fsequence sequence) + (assert-subtype %fsequence function) + (assert-instance-type %fsequence (not stream))) +(with-test (:name (sequence function funcall)) + (assert-callable %fsequence)) + +(macrolet ((test (stype) + (let ((sname (intern (concatenate 'string "%SEQ" (symbol-name stype)))) + (fsname (intern (concatenate 'string "%FSEQ" (symbol-name stype))))) + `(progn + (defclass ,sname (,stype sequence standard-object) + ()) + (with-test (:name (,stype sequence standard-object)) + (assert-subtype ,sname ,stype) + (assert-instance-type ,sname (not function)) + (assert-subtype ,sname sequence)) + + (defclass ,fsname (,stype sequence sb-mop:funcallable-standard-object) + () + (:metaclass sb-mop:funcallable-standard-class)) + (with-test (:name (,stype sequence function)) + (assert-subtype ,fsname ,stype) + (assert-subtype ,fsname function) + (assert-subtype ,fsname sequence)) + (with-test (:name (,stype sequence function funcall)) + (assert-callable ,fsname)))))) + (test stream) + (test file-stream) + (test string-stream)) +