From 8fe977ca5d0d068f2641dd06d3743a4c218d5cc1 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Fri, 3 Oct 2008 12:21:09 +0000 Subject: [PATCH] 1.0.21.1: address TYPE-WARNING in CLOS allocator for funcallable structures ... parallel %make-funcallable-structure-allocator; ... make FUNCTION-classoid-subclasses into CLOS classes in FIXUP ... also make !DEFSTRUCT-W-A-M respect *DEFSTRUCT-HOOKS* just in case. ... test. --- package-data-list.lisp-expr | 1 + src/code/defstruct.lisp | 23 +++++++++++++++++++++-- src/pcl/defs.lisp | 12 +++--------- src/pcl/fixup.lisp | 3 +-- src/pcl/std-class.lisp | 6 +++++- tests/type.impure.lisp | 6 ++++++ version.lisp-expr | 2 +- 7 files changed, 38 insertions(+), 15 deletions(-) diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index 2cb78b8..f5e22ab 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1231,6 +1231,7 @@ is a good idea, but see SB-SYS re. blurring of boundaries." "%LOG1P" #!+long-float "%LONG-FLOAT" "%MAKE-COMPLEX" "%MAKE-FUNCALLABLE-INSTANCE" + "%MAKE-FUNCALLABLE-STRUCTURE-INSTANCE-ALLOCATOR" "%MAKE-RATIO" "%MAKE-LISP-OBJ" "%MAKE-INSTANCE" "%MAKE-STRUCTURE-INSTANCE" diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index dc18208..9743b65 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -47,12 +47,25 @@ ,@slot-vars)))))) (declaim (ftype (sfunction (defstruct-description list) function) - %Make-structure-instance-allocator)) + %make-structure-instance-allocator)) (defun %make-structure-instance-allocator (dd slot-specs) (let ((vars (make-gensym-list (length slot-specs)))) (values (compile nil `(lambda (,@vars) (%make-structure-instance-macro ,dd ',slot-specs ,@vars)))))) +(defun %make-funcallable-structure-instance-allocator (dd slot-specs) + (when slot-specs + (bug "funcallable-structure-instance allocation with slots unimplemented")) + (let ((name (dd-name dd)) + (length (dd-length dd)) + (nobject (gensym "OBJECT"))) + (values + (compile nil `(lambda () + (let ((,nobject (%make-funcallable-instance ,length))) + (setf (%funcallable-instance-layout ,nobject) + (%delayed-get-compiler-layout ,name)) + ,nobject)))))) + ;;; Delay looking for compiler-layout until the constructor is being ;;; compiled, since it doesn't exist until after the EVAL-WHEN ;;; (COMPILE) stuff is compiled. (Or, in the oddball case when @@ -1701,6 +1714,8 @@ (eval-when (:compile-toplevel :load-toplevel :execute) (%compiler-set-up-layout ',dd ',(inherits-for-structure dd)))))) +(sb!xc:proclaim '(special *defstruct-hooks*)) + (sb!xc:defmacro !defstruct-with-alternate-metaclass (class-name &key (slot-names (missing-arg)) @@ -1795,7 +1810,11 @@ ;; code, which knows how to generate inline type tests ;; for the whole CMU CL INSTANCE menagerie. `(defun ,predicate (,object-gensym) - (typep ,object-gensym ',class-name))))))) + (typep ,object-gensym ',class-name))) + + (when (boundp '*defstruct-hooks*) + (dolist (fun *defstruct-hooks*) + (funcall fun (find-classoid ',(dd-name dd))))))))) ;;;; finalizing bootstrapping diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index bf3dc71..674519e 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -680,15 +680,9 @@ (defclass condition-class (slot-class) ()) (defclass structure-class (slot-class) - ((defstruct-form - :initform () - :accessor class-defstruct-form) - (defstruct-constructor - :initform nil - :accessor class-defstruct-constructor) - (from-defclass-p - :initform nil - :initarg :from-defclass-p))) + ((defstruct-form :initform () :accessor class-defstruct-form) + (defstruct-constructor :initform nil :accessor class-defstruct-constructor) + (from-defclass-p :initform nil :initarg :from-defclass-p))) (defclass definition-source-mixin (standard-object) ((source diff --git a/src/pcl/fixup.lisp b/src/pcl/fixup.lisp index 6244ebb..2ea6fb9 100644 --- a/src/pcl/fixup.lisp +++ b/src/pcl/fixup.lisp @@ -26,7 +26,7 @@ (!fix-early-generic-functions) (!fix-ensure-accessor-specializers) (compute-standard-slot-locations) -(dolist (s '(condition structure-object)) +(dolist (s '(condition function structure-object)) (dohash ((k v) (classoid-subclasses (find-classoid s))) (find-class (classoid-name k)))) (setq *boot-state* 'complete) @@ -34,4 +34,3 @@ (defun print-std-instance (instance stream depth) (declare (ignore depth)) (print-object instance stream)) - diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 675d115..ab1406f 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -658,7 +658,11 @@ (defun make-defstruct-allocation-function (name) ;; FIXME: Why don't we go class->layout->info == dd (let ((dd (find-defstruct-description name))) - (%make-structure-instance-allocator dd nil))) + (ecase (dd-type dd) + (structure + (%make-structure-instance-allocator dd nil)) + (funcallable-structure + (%make-funcallable-structure-instance-allocator dd nil))))) (defmethod shared-initialize :after ((class structure-class) slot-names &key diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp index e1e0b73..b5e981f 100644 --- a/tests/type.impure.lisp +++ b/tests/type.impure.lisp @@ -435,6 +435,12 @@ (with-test (:name (:ctor :functionp)) (assert (functionp (sb-pcl::ensure-ctor (list 'sb-pcl::ctor (gensym)) nil nil nil)))) +;;; some new (2008-10-03) ways of going wrong... +(with-test (:name (:ctor-allocate-instance :typep-function)) + (assert (eval '(typep (allocate-instance (find-class 'sb-pcl::ctor)) + 'function)))) +(with-test (:name (:ctor-allocate-instance :functionp)) + (assert (functionp (allocate-instance (find-class 'sb-pcl::ctor))))) ;;; from PFD ansi-tests (let ((t1 '(cons (cons (cons (real -744833699 -744833699) cons) diff --git a/version.lisp-expr b/version.lisp-expr index fd5c34c..f045380 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"1.0.21" +"1.0.21.1" -- 1.7.10.4