common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Restore funcallable sequences

Browse source 
Absence of tests meant that a prior simplification (revision
17945c81f9) 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
This commit is contained in:
Christophe Rhodes 2024-01-24 08:35:42 +00:00
parent b3f890a81d
commit 12332bbfc7
7 changed files with 226 additions and 27 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

5
NEWS
View file

@ -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.

46
src/code/class.lisp
View file

@ -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))

18
src/code/coerce.lisp
View file

@ -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

1
src/cold/exports.lisp
View file

@ -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"

5
src/compiler/typetran.lisp
View file

@ -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)

83
tests/extended-sequences.impure.lisp
View file

@ -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)))))

95
tests/mop-35.impure.lisp Normal file
View file

@ -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))