From 4f8f4b25cb564509437d8fc26038143150077f14 Mon Sep 17 00:00:00 2001 From: Juho Snellman Date: Tue, 7 Nov 2006 10:22:09 +0000 Subject: [PATCH] 0.9.18.38: Typechecking for CLOS instance slots, based on the earlier clos-typechecking branch by Christophe Rhodes. To get the typechecking right, especially when considering inheritance where the slots in subclasses can have tighter :TYPEs than in the superclass, some major PCL optimizations need to be disabled. This slows down slot writes significantly. Typechecking is thus only enabled for safe code. * Store a function in each slot-definition with a non-T :TYPE, which checks whether its parameter is of the proper type for the slot. * Store in each class knowledge about whether the class was defined in an environment with (SAFETY 3) policy. * Don't do PV optimization for SETF of SLOT-VALUE in safe code. * When generating writer methods for classes defined in safe code, fetch the appropriate slotd for the instance and call its type-checking-function (if one exists) before doing the slot write. * Do the same in the slow path of SET-SLOT-VALUE * When generating a ctor for a MAKE-INSTANCE call in safe code, check the types of the supplied initargs. * Fix declaration handling for some binding forms in SB-WALK * Remove dead accessor-call optimization code * Tests --- NEWS | 4 +- src/pcl/boot.lisp | 9 -- src/pcl/braid.lisp | 2 + src/pcl/ctor.lisp | 130 +++++++++++-------- src/pcl/defclass.lisp | 37 ++++-- src/pcl/defs.lisp | 9 ++ src/pcl/dfun.lisp | 12 +- src/pcl/fsc.lisp | 4 +- src/pcl/slots-boot.lisp | 178 +++++++++++++++++--------- src/pcl/slots.lisp | 57 ++++++--- src/pcl/std-class.lisp | 27 ++-- src/pcl/vector.lisp | 157 +++++------------------ src/pcl/walk.lisp | 109 ++++++++-------- tests/clos-typechecking.impure.lisp | 234 +++++++++++++++++++++++++++++++++++ tests/mop.impure-cload.lisp | 2 +- tests/type.impure.lisp | 4 +- version.lisp-expr | 2 +- 17 files changed, 632 insertions(+), 345 deletions(-) create mode 100644 tests/clos-typechecking.impure.lisp diff --git a/NEWS b/NEWS index 5b50cf3..950ae47 100644 --- a/NEWS +++ b/NEWS @@ -8,8 +8,10 @@ changes in sbcl-0.9.19 (1.0.0?) relative to sbcl-0.9.18: startup, not time since first call to GET-INTERNAL-REAL-TIME. * improvement: SAVE-LISP-AND-DIE explicitly checks that multiple threads are not running after *SAVE-HOOKS* have run. + * improvement: writes to CLOS instance slots are type-checked in code + compiled with (SAFETY 3) * improvement: floating-point exception handling should work on all - POSIX platforms (thanks to NIIMI Satoshi) + POSIX platforms (thanks to NIIMI Satoshi) * bug fix: compiler bug triggered by a (non-standard) VALUES declaration in a LET* was fixed. (reported by Kaersten Poeck) * bug fix: file compiler no longer confuses validated and already diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 3051e17..66d26ef 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -1371,15 +1371,6 @@ bootstrapping. (set-slot-value #'optimize-set-slot-value) (slot-boundp #'optimize-slot-boundp)))) (funcall fun slots parameter form)))) - ((and (eq (car form) 'apply) - (consp (cadr form)) - (eq (car (cadr form)) 'function) - (generic-function-name-p (cadr (cadr form)))) - (optimize-generic-function-call - form required-parameters env slots calls)) - ((generic-function-name-p (car form)) - (optimize-generic-function-call - form required-parameters env slots calls)) (t form)))) (let ((walked-lambda (walk-form method-lambda env #'walk-function))) diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index 7419297..6f956ce 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -276,6 +276,7 @@ (set-slot 'name name) (set-slot 'finalized-p t) (set-slot 'source source) + (set-slot 'safe-p nil) (set-slot '%type (if (eq class (find-class t)) t ;; FIXME: Could this just be CLASS instead @@ -369,6 +370,7 @@ (set-val 'writers (get-val :writers)) (set-val 'allocation :instance) (set-val '%type (or (get-val :type) t)) + (set-val '%type-check-function (get-val 'type-check-function)) (set-val '%documentation (or (get-val :documentation) "")) (set-val '%class class) (when effective-p diff --git a/src/pcl/ctor.lisp b/src/pcl/ctor.lisp index 0c2e4eb..743a69c 100644 --- a/src/pcl/ctor.lisp +++ b/src/pcl/ctor.lisp @@ -107,7 +107,7 @@ ;;; funcallable instance is set to it. ;;; (!defstruct-with-alternate-metaclass ctor - :slot-names (function-name class-name class initargs) + :slot-names (function-name class-name class initargs safe-p) :boa-constructor %make-ctor :superclass-name function :metaclass-name static-classoid @@ -134,18 +134,18 @@ (setf (%funcallable-instance-info ctor 1) (ctor-function-name ctor)))) -(defun make-ctor-function-name (class-name initargs) - (list* 'ctor class-name initargs)) +(defun make-ctor-function-name (class-name initargs safe-code-p) + (list* 'ctor class-name safe-code-p initargs)) ;;; Keep this a separate function for testing. -(defun ensure-ctor (function-name class-name initargs) +(defun ensure-ctor (function-name class-name initargs safe-code-p) (unless (fboundp function-name) - (make-ctor function-name class-name initargs))) + (make-ctor function-name class-name initargs safe-code-p))) ;;; Keep this a separate function for testing. -(defun make-ctor (function-name class-name initargs) +(defun make-ctor (function-name class-name initargs safe-p) (without-package-locks ; for (setf symbol-function) - (let ((ctor (%make-ctor function-name class-name nil initargs))) + (let ((ctor (%make-ctor function-name class-name nil initargs safe-p))) (push ctor *all-ctors*) (setf (fdefinition function-name) ctor) (install-initial-constructor ctor :force-p t) @@ -156,12 +156,12 @@ ;;; Compile-Time Expansion of MAKE-INSTANCE ******* ;;; *********************************************** -(define-compiler-macro make-instance (&whole form &rest args) +(define-compiler-macro make-instance (&whole form &rest args &environment env) (declare (ignore args)) - (or (make-instance->constructor-call form) + (or (make-instance->constructor-call form (safe-code-p env)) form)) -(defun make-instance->constructor-call (form) +(defun make-instance->constructor-call (form safe-code-p) (destructuring-bind (fn class-name &rest args) form (declare (ignore fn)) (flet (;; @@ -201,7 +201,8 @@ finally (return (values initargs value-forms))) (let* ((class-name (constant-form-value class-name)) - (function-name (make-ctor-function-name class-name initargs))) + (function-name (make-ctor-function-name class-name initargs + safe-code-p))) ;; Prevent compiler warnings for calling the ctor. (proclaim-as-fun-name function-name) (note-name-defined function-name :function) @@ -215,7 +216,8 @@ `(locally (declare (disable-package-locks ,function-name)) (let ((.x. (load-time-value - (ensure-ctor ',function-name ',class-name ',initargs)))) + (ensure-ctor ',function-name ',class-name ',initargs + ',safe-code-p)))) (declare (ignore .x.)) ;; ??? check if this is worth it. (declare @@ -453,6 +455,15 @@ finally (return (values around before (first primary) (reverse after))))) +(defmacro with-type-checked ((type safe-p) &body body) + (if safe-p + ;; To handle FUNCTION types reasonable, we use SAFETY 3 and + ;; THE instead of e.g. CHECK-TYPE. + `(locally + (declare (optimize (safety 3))) + (the ,type (progn ,@body))) + `(progn ,@body))) + ;;; Return as multiple values bindings for default initialization ;;; arguments, variable names, defaulting initargs and a body for ;;; initializing instance and class slots of an object costructed by @@ -465,6 +476,7 @@ (let* ((class (ctor-class ctor)) (initargs (ctor-initargs ctor)) (initkeys (plist-keys initargs)) + (safe-p (ctor-safe-p ctor)) (slot-vector (make-array (layout-length (class-wrapper class)) :initial-element nil)) @@ -484,14 +496,14 @@ ((integerp location) (not (null (aref slot-vector location)))) (t (bug "Weird location in ~S" 'slot-init-forms)))) - (class-init (location type val) + (class-init (location kind val type) (aver (consp location)) (unless (initializedp location) - (push (list location type val) class-inits))) - (instance-init (location type val) + (push (list location kind val type) class-inits))) + (instance-init (location kind val type) (aver (integerp location)) (unless (initializedp location) - (setf (aref slot-vector location) (list type val)))) + (setf (aref slot-vector location) (list kind val type)))) (default-init-var-name (i) (let ((ps #(.d0. .d1. .d2. .d3. .d4. .d5.))) (if (array-in-bounds-p ps i) @@ -505,16 +517,12 @@ ;; Loop over supplied initargs and values and record which ;; instance and class slots they initialize. (loop for (key value) on initargs by #'cddr - as locations = (initarg-locations key) do - (if (constantp value) - (dolist (location locations) - (if (consp location) - (class-init location 'constant value) - (instance-init location 'constant value))) - (dolist (location locations) - (if (consp location) - (class-init location 'param value) - (instance-init location 'param value))))) + as kind = (if (constantp value) 'constant 'param) + as locations = (initarg-locations key) + do (loop for (location . type) in locations + do (if (consp location) + (class-init location kind value type) + (instance-init location kind value type)))) ;; Loop over default initargs of the class, recording ;; initializations of slots that have not been initialized ;; above. Default initargs which are not in the supplied @@ -523,27 +531,28 @@ ;; if not actually used for initializing a slot. (loop for (key initform initfn) in default-initargs and i from 0 unless (member key initkeys :test #'eq) do - (let* ((type (if (constantp initform) 'constant 'var)) - (init (if (eq type 'var) initfn initform))) - (ecase type + (let* ((kind (if (constantp initform) 'constant 'var)) + (init (if (eq kind 'var) initfn initform))) + (ecase kind (constant (push key defaulting-initargs) (push initform defaulting-initargs)) (var (push key defaulting-initargs) (push (default-init-var-name i) defaulting-initargs))) - (when (eq type 'var) + (when (eq kind 'var) (let ((init-var (default-init-var-name i))) (setq init init-var) (push (cons init-var initfn) default-inits))) - (dolist (location (initarg-locations key)) - (if (consp location) - (class-init location type init) - (instance-init location type init))))) + (loop for (location . type) in (initarg-locations key) + do (if (consp location) + (class-init location kind init type) + (instance-init location kind init type))))) ;; Loop over all slots of the class, filling in the rest from ;; slot initforms. (loop for slotd in (class-slots class) as location = (slot-definition-location slotd) + as type = (slot-definition-type slotd) as allocation = (slot-definition-allocation slotd) as initfn = (slot-definition-initfunction slotd) as initform = (slot-definition-initform slotd) do @@ -551,54 +560,64 @@ (null initfn) (initializedp location)) (if (constantp initform) - (instance-init location 'initform initform) - (instance-init location 'initform/initfn initfn)))) + (instance-init location 'initform initform type) + (instance-init location 'initform/initfn initfn type)))) ;; Generate the forms for initializing instance and class slots. (let ((instance-init-forms (loop for slot-entry across slot-vector and i from 0 - as (type value) = slot-entry collect - (ecase type + as (kind value type) = slot-entry collect + (ecase kind ((nil) (unless before-method-p `(setf (clos-slots-ref .slots. ,i) +slot-unbound+))) ((param var) - `(setf (clos-slots-ref .slots. ,i) ,value)) + `(setf (clos-slots-ref .slots. ,i) + (with-type-checked (,type ,safe-p) + ,value))) (initfn - `(setf (clos-slots-ref .slots. ,i) (funcall ,value))) + `(setf (clos-slots-ref .slots. ,i) + (with-type-checked (,type ,safe-p) + (funcall ,value)))) (initform/initfn (if before-method-p `(when (eq (clos-slots-ref .slots. ,i) +slot-unbound+) (setf (clos-slots-ref .slots. ,i) - (funcall ,value))) + (with-type-checked (,type ,safe-p) + (funcall ,value)))) `(setf (clos-slots-ref .slots. ,i) - (funcall ,value)))) + (with-type-checked (,type ,safe-p) + (funcall ,value))))) (initform (if before-method-p `(when (eq (clos-slots-ref .slots. ,i) +slot-unbound+) (setf (clos-slots-ref .slots. ,i) - ',(constant-form-value value))) + (with-type-checked (,type ,safe-p) + ',(constant-form-value value)))) `(setf (clos-slots-ref .slots. ,i) - ',(constant-form-value value)))) + (with-type-checked (,type ,safe-p) + ',(constant-form-value value))))) (constant `(setf (clos-slots-ref .slots. ,i) - ',(constant-form-value value))))))) + (with-type-checked (,type ,safe-p) + ',(constant-form-value value)))))))) ;; we are not allowed to modify QUOTEd locations, so we can't ;; generate code like (setf (cdr ',location) arg). Instead, ;; we have to do (setf (cdr .L0.) arg) and arrange for .L0. to ;; be bound to the location. (multiple-value-bind (names locations class-init-forms) - (loop for (location type value) in class-inits + (loop for (location kind value type) in class-inits for i upfrom 0 for name = (location-var-name i) collect name into names collect location into locations collect `(setf (cdr ,name) - ,(case type - (constant `',(constant-form-value value)) - ((param var) `,value) - (initfn `(funcall ,value)))) + (with-type-checked (,type ,safe-p) + ,(case kind + (constant `',(constant-form-value value)) + ((param var) `,value) + (initfn `(funcall ,value))))) into class-init-forms finally (return (values names locations class-init-forms))) (multiple-value-bind (vars bindings) @@ -612,15 +631,18 @@ `(,@(delete nil instance-init-forms) ,@class-init-forms)))))))) -;;; Return an alist of lists (KEY LOCATION ...) telling, for each -;;; key in INITKEYS, which locations the initarg initializes. -;;; CLASS is the class of the instance being initialized. +;;; Return an alist of lists (KEY (LOCATION . TYPE-SPECIFIER) ...) +;;; telling, for each key in INITKEYS, which locations the initarg +;;; initializes and the associated type with the location. CLASS is +;;; the class of the instance being initialized. (defun compute-initarg-locations (class initkeys) (loop with slots = (class-slots class) for key in initkeys collect (loop for slot in slots if (memq key (slot-definition-initargs slot)) - collect (slot-definition-location slot) into locations + collect (cons (slot-definition-location slot) + (slot-definition-type slot)) + into locations else collect slot into remaining-slots finally diff --git a/src/pcl/defclass.lisp b/src/pcl/defclass.lisp index 831dcdd..cbce704 100644 --- a/src/pcl/defclass.lisp +++ b/src/pcl/defclass.lisp @@ -72,7 +72,8 @@ ',*readers-for-this-defclass* ',*writers-for-this-defclass* ',*slot-names-for-this-defclass* - (sb-c:source-location))))) + (sb-c:source-location) + ',(safe-code-p env))))) (if defstruct-p (progn ;; FIXME: (YUK!) Why do we do this? Because in order @@ -183,6 +184,7 @@ (initargs ()) (others ()) (unsupplied (list nil)) + (type t) (initform unsupplied)) (check-slot-name-for-defclass name class-name env) (push name *slot-names-for-this-defclass*) @@ -213,6 +215,8 @@ (when (member key '(:initform :allocation :type :documentation)) (when (eq key :initform) (setf initform val)) + (when (eq key :type) + (setf type val)) (when (get-properties others (list key)) (error 'simple-program-error :format-control "Duplicate slot option ~S for slot ~ @@ -225,8 +229,16 @@ ((null head)) (unless (cdr (second head)) (setf (second head) (car (second head))))) - (let ((canon `(:name ',name :readers ',readers :writers ',writers - :initargs ',initargs ',others))) + (let* ((type-check-function + (if (eq type t) + nil + `('type-check-function (lambda (value) + (declare (type ,type value)) + value)))) + (canon `(:name ',name :readers ',readers :writers ',writers + :initargs ',initargs + ,@type-check-function + ',others))) (push (if (eq initform unsupplied) `(list* ,@canon) `(list* :initfunction ,(make-initfunction initform) @@ -465,20 +477,23 @@ (declaim (notinline load-defclass)) (defun load-defclass (name metaclass supers canonical-slots canonical-options - readers writers slot-names source-location) + readers writers slot-names source-location safe-p) + ;; SAFE-P is used by REAL-LOAD-DEFCLASS, but can be ignored here, since + ;; during the bootstrap we won't have (SAFETY 3). + (declare (ignore safe-p)) (%compiler-defclass name readers writers slot-names) (setq supers (copy-tree supers) canonical-slots (copy-tree canonical-slots) canonical-options (copy-tree canonical-options)) (let ((ecd - (make-early-class-definition name - source-location - metaclass - supers - canonical-slots - canonical-options)) + (make-early-class-definition name + source-location + metaclass + supers + canonical-slots + canonical-options)) (existing - (find name *early-class-definitions* :key #'ecd-class-name))) + (find name *early-class-definitions* :key #'ecd-class-name))) (setq *early-class-definitions* (cons ecd (remove existing *early-class-definitions*))) ecd)) diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index 6cd5a77..607f6c5 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -458,6 +458,9 @@ :initarg :initargs :accessor slot-definition-initargs) (%type :initform t :initarg :type :accessor slot-definition-type) + (%type-check-function :initform nil + :initarg type-check-function + :accessor slot-definition-type-check-function) (%documentation :initform nil :initarg :documentation ;; KLUDGE: we need a reader for bootstrapping purposes, in @@ -599,6 +602,12 @@ (%documentation :initform nil :initarg :documentation) + ;; True if the class definition was compiled with a (SAFETY 3) + ;; optimization policy. + (safe-p + :initform nil + :initarg safe-p + :accessor safe-p) (finalized-p :initform nil :reader class-finalized-p))) diff --git a/src/pcl/dfun.lisp b/src/pcl/dfun.lisp index 3765007..a83e037 100644 --- a/src/pcl/dfun.lisp +++ b/src/pcl/dfun.lisp @@ -897,8 +897,12 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (let ((class (early-method-class method))) (or (eq class *the-class-standard-writer-method*) (eq class *the-class-global-writer-method*))) - (or (standard-writer-method-p method) - (global-writer-method-p method)))) + (and + (or (standard-writer-method-p method) + (global-writer-method-p method)) + (not (safe-p + (slot-definition-class + (accessor-method-slot-definition method))))))) methods) 'writer)))) @@ -1281,7 +1285,9 @@ Except see also BREAK-VICIOUS-METACIRCLE. -- CSR, 2003-05-28 (find-slot-definition accessor-class slot-name))))) (when (and slotd (or early-p - (slot-accessor-std-p slotd accessor-type))) + (slot-accessor-std-p slotd accessor-type)) + (or early-p + (not (safe-p accessor-class)))) (values (if early-p (early-slot-definition-location slotd) (slot-definition-location slotd)) diff --git a/src/pcl/fsc.lisp b/src/pcl/fsc.lisp index 8313078..4d118a4 100644 --- a/src/pcl/fsc.lisp +++ b/src/pcl/fsc.lisp @@ -51,11 +51,11 @@ (defmethod make-reader-method-function ((class funcallable-standard-class) slot-name) - (make-std-reader-method-function (class-name class) slot-name)) + (make-std-reader-method-function class slot-name)) (defmethod make-writer-method-function ((class funcallable-standard-class) slot-name) - (make-std-writer-method-function (class-name class) slot-name)) + (make-std-writer-method-function class slot-name)) ;;;; See the comment about reader-function--std and writer-function--sdt. ;;;; diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp index 60d3cec..c69646a 100644 --- a/src/pcl/slots-boot.lisp +++ b/src/pcl/slots-boot.lisp @@ -192,28 +192,54 @@ (defun make-optimized-std-writer-method-function (fsc-p slotd slot-name location) (declare #.*optimize-speed*) - (set-fun-name - (etypecase location - (fixnum (if fsc-p - (lambda (nv instance) - (check-obsolete-instance instance) - (setf (clos-slots-ref (fsc-instance-slots instance) - location) - nv)) - (lambda (nv instance) - (check-obsolete-instance instance) - (setf (clos-slots-ref (std-instance-slots instance) - location) - nv)))) - (cons (lambda (nv instance) - (check-obsolete-instance instance) - (setf (cdr location) nv))) - (null - (lambda (nv instance) - (declare (ignore nv)) - (instance-structure-protocol-error slotd - '(setf slot-value-using-class))))) - `(writer ,slot-name))) + (let* ((safe-p (and slotd + (slot-definition-class slotd) + (safe-p (slot-definition-class slotd)))) + (writer-fun (etypecase location + (fixnum (if fsc-p + (lambda (nv instance) + (check-obsolete-instance instance) + (setf (clos-slots-ref (fsc-instance-slots instance) + location) + nv)) + (lambda (nv instance) + (check-obsolete-instance instance) + (setf (clos-slots-ref (std-instance-slots instance) + location) + nv)))) + (cons (lambda (nv instance) + (check-obsolete-instance instance) + (setf (cdr location) nv))) + (null + (lambda (nv instance) + (declare (ignore nv instance)) + (instance-structure-protocol-error + slotd + '(setf slot-value-using-class)))))) + (checking-fun (lambda (new-value instance) + (check-obsolete-instance instance) + ;; If the SLOTD had a TYPE-CHECK-FUNCTION, call it. + (let* (;; Note that this CLASS is not neccessarily + ;; the SLOT-DEFINITION-CLASS of the + ;; SLOTD passed to M-O-S-W-M-F, since it's + ;; e.g. possible for a subclass to define + ;; a slot of the same name but with no + ;; accessors. So we need to fetch the SLOTD + ;; when CHECKING-FUN is called, instead of + ;; just closing over it. + (class (class-of instance)) + (slotd (find-slot-definition class slot-name)) + (type-check-function + (when slotd + (slot-definition-type-check-function slotd)))) + (when type-check-function + (funcall type-check-function new-value))) + ;; Then call the real writer. + (funcall writer-fun new-value instance)))) + (set-fun-name (if safe-p + checking-fun + writer-fun) + `(writer ,slot-name)))) (defun make-optimized-std-boundp-method-function (fsc-p slotd slot-name location) @@ -341,28 +367,42 @@ (defun make-optimized-std-setf-slot-value-using-class-method-function (fsc-p slotd) (declare #.*optimize-speed*) - (let ((location (slot-definition-location slotd))) - (etypecase location - (fixnum - (if fsc-p - (lambda (nv class instance slotd) - (declare (ignore class slotd)) - (check-obsolete-instance instance) - (setf (clos-slots-ref (fsc-instance-slots instance) location) - nv)) - (lambda (nv class instance slotd) - (declare (ignore class slotd)) - (check-obsolete-instance instance) - (setf (clos-slots-ref (std-instance-slots instance) location) - nv)))) - (cons (lambda (nv class instance slotd) - (declare (ignore class slotd)) - (check-obsolete-instance instance) - (setf (cdr location) nv))) - (null (lambda (nv class instance slotd) - (declare (ignore nv class instance)) - (instance-structure-protocol-error - slotd '(setf slot-value-using-class))))))) + (let ((location (slot-definition-location slotd)) + (type-check-function + (when (and slotd + (slot-definition-class slotd) + (safe-p (slot-definition-class slotd))) + (slot-definition-type-check-function slotd)))) + (macrolet ((make-mf-lambda (&body body) + `(lambda (nv class instance slotd) + (declare (ignore class slotd)) + (check-obsolete-instance instance) + ,@body)) + (make-mf-lambdas (&body body) + ;; Having separate lambdas for the NULL / not-NULL cases of + ;; TYPE-CHECK-FUNCTION is done to avoid runtime overhead + ;; for CLOS typechecking when it's not in use. + `(if type-check-function + (make-mf-lambda + (funcall (the function type-check-function) nv) + ,@body) + (make-mf-lambda + ,@body)))) + (etypecase location + (fixnum + (if fsc-p + (make-mf-lambdas + (setf (clos-slots-ref (fsc-instance-slots instance) location) + nv)) + (make-mf-lambdas + (setf (clos-slots-ref (std-instance-slots instance) location) + nv)))) + (cons + (make-mf-lambdas (setf (cdr location) nv))) + (null (lambda (nv class instance slotd) + (declare (ignore nv class instance)) + (instance-structure-protocol-error + slotd '(setf slot-value-using-class)))))))) (defun make-optimized-std-slot-boundp-using-class-method-function (fsc-p slotd) @@ -404,7 +444,8 @@ (emf-funcall sdfun class instance slotd)))) `(,name ,(class-name class) ,(slot-definition-name slotd))))) -(defun make-std-reader-method-function (class-name slot-name) +(defun make-std-reader-method-function (class-or-name slot-name) + (declare (ignore class-or-name)) (let* ((initargs (copy-tree (make-method-function (lambda (instance) @@ -418,21 +459,46 @@ (list (list nil slot-name))) initargs)) -(defun make-std-writer-method-function (class-name slot-name) - (let* ((initargs (copy-tree - (make-method-function - (lambda (nv instance) - (pv-binding1 (.pv. .calls. - (bug "Please report this") - (instance) (instance-slots)) - (instance-write-internal - .pv. instance-slots 0 nv - (setf (slot-value instance slot-name) nv)))))))) +(defun make-std-writer-method-function (class-or-name slot-name) + (let* ((class (when (eq *boot-state* 'complete) + (if (typep class-or-name 'class) + class-or-name + (find-class class-or-name nil)))) + (safe-p (and class + (safe-p class))) + (check-fun (lambda (new-value instance) + (let* ((class (class-of instance)) + (slotd (find-slot-definition class slot-name)) + (type-check-function + (when slotd + (slot-definition-type-check-function slotd)))) + (when type-check-function + (funcall type-check-function new-value))))) + (initargs (copy-tree + (if safe-p + (make-method-function + (lambda (nv instance) + (funcall check-fun nv instance) + (pv-binding1 (.pv. .calls. + (bug "Please report this") + (instance) (instance-slots)) + (instance-write-internal + .pv. instance-slots 0 nv + (setf (slot-value instance slot-name) nv))))) + (make-method-function + (lambda (nv instance) + (pv-binding1 (.pv. .calls. + (bug "Please report this") + (instance) (instance-slots)) + (instance-write-internal + .pv. instance-slots 0 nv + (setf (slot-value instance slot-name) nv))))))))) (setf (getf (getf initargs 'plist) :slot-name-lists) (list nil (list nil slot-name))) initargs)) -(defun make-std-boundp-method-function (class-name slot-name) +(defun make-std-boundp-method-function (class-or-name slot-name) + (declare (ignore class-or-name)) (let* ((initargs (copy-tree (make-method-function (lambda (instance) diff --git a/src/pcl/slots.lisp b/src/pcl/slots.lisp index 1b1326b..aade5b2 100644 --- a/src/pcl/slots.lisp +++ b/src/pcl/slots.lisp @@ -103,9 +103,23 @@ (setf (slot-value-using-class class object slot-definition) new-value)))) -(define-compiler-macro set-slot-value (&whole form object slot-name new-value) +;;; A version of SET-SLOT-VALUE for use in safe code, where we want to +;;; check types when writing to slots: +;;; * Doesn't have an optimizing compiler-macro +;;; * Isn't special-cased in WALK-METHOD-LAMBDA +(defun safe-set-slot-value (object slot-name new-value) + (set-slot-value object slot-name new-value)) + +(define-compiler-macro set-slot-value (&whole form object slot-name new-value + &environment env) (if (and (constantp slot-name) - (interned-symbol-p (constant-form-value slot-name))) + (interned-symbol-p (constant-form-value slot-name)) + ;; We can't use the ACCESSOR-SET-SLOT-VALUE path in safe + ;; code, since it'll use the global automatically generated + ;; accessor, which won't do typechecking. (SLOT-OBJECT + ;; won't have been compiled with SAFETY 3, so SAFE-P will + ;; be NIL in MAKE-STD-WRITER-METHOD-FUNCTION). + (not (safe-code-p env))) `(accessor-set-slot-value ,object ,slot-name ,new-value) form)) @@ -182,22 +196,29 @@ (object standard-object) (slotd standard-effective-slot-definition)) (check-obsolete-instance object) - (let ((location (slot-definition-location slotd))) - (typecase location - (fixnum - (cond ((std-instance-p object) - (setf (clos-slots-ref (std-instance-slots object) location) - new-value)) - ((fsc-instance-p object) - (setf (clos-slots-ref (fsc-instance-slots object) location) - new-value)) - (t (bug "unrecognized instance type in ~S" - '(setf slot-value-using-class))))) - (cons - (setf (cdr location) new-value)) - (t - (instance-structure-protocol-error slotd - '(setf slot-value-using-class)))))) + (let ((location (slot-definition-location slotd)) + (type-check-function + (when (safe-p class) + (slot-definition-type-check-function slotd)))) + (flet ((check (new-value) + (when type-check-function + (funcall (the function type-check-function) new-value)) + new-value)) + (typecase location + (fixnum + (cond ((std-instance-p object) + (setf (clos-slots-ref (std-instance-slots object) location) + (check new-value))) + ((fsc-instance-p object) + (setf (clos-slots-ref (fsc-instance-slots object) location) + (check new-value))) + (t (bug "unrecognized instance type in ~S" + '(setf slot-value-using-class))))) + (cons + (setf (cdr location) (check new-value))) + (t + (instance-structure-protocol-error + slotd '(setf slot-value-using-class))))))) (defmethod slot-boundp-using-class ((class std-class) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 652b1bd..733c4d3 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -286,13 +286,14 @@ (constantly (make-member-type :members (list (specializer-object specl)))))) (defun real-load-defclass (name metaclass-name supers slots other - readers writers slot-names source-location) + readers writers slot-names source-location safe-p) (with-single-package-locked-error (:symbol name "defining ~S as a class") (%compiler-defclass name readers writers slot-names) (let ((res (apply #'ensure-class name :metaclass metaclass-name :direct-superclasses supers :direct-slots slots :definition-source source-location + 'safe-p safe-p other))) res))) @@ -1036,6 +1037,7 @@ (allocation nil) (allocation-class nil) (type t) + (type-check-function nil) (documentation nil) (documentationp nil) (namep nil) @@ -1061,6 +1063,15 @@ allocation-class (slot-definition-class slotd) allocp t)) (setq initargs (append (slot-definition-initargs slotd) initargs)) + (let ((fun (slot-definition-type-check-function slotd))) + (when fun + (setf type-check-function + (if type-check-function + (let ((old-function type-check-function)) + (lambda (value) + (funcall old-function value) + (funcall fun value))) + fun)))) (let ((slotd-type (slot-definition-type slotd))) (setq type (cond ((eq type t) slotd-type) @@ -1077,6 +1088,7 @@ :allocation allocation :allocation-class allocation-class :type type + 'type-check-function type-check-function :class class :documentation documentation))) @@ -1150,9 +1162,10 @@ (let ((method (get-method generic-function () (list class) nil))) (when method (remove-method generic-function method)))) -;;; MAKE-READER-METHOD-FUNCTION and MAKE-WRITE-METHOD function are NOT -;;; part of the standard protocol. They are however useful, PCL makes -;;; use of them internally and documents them for PCL users. +;;; MAKE-READER-METHOD-FUNCTION and MAKE-WRITER-METHOD-FUNCTION +;;; function are NOT part of the standard protocol. They are however +;;; useful; PCL makes use of them internally and documents them for +;;; PCL users. (FIXME: but SBCL certainly doesn't) ;;; ;;; *** This needs work to make type testing by the writer functions which ;;; *** do type testing faster. The idea would be to have one constructor @@ -1164,13 +1177,13 @@ ;;; *** defined for this metaclass a chance to run. (defmethod make-reader-method-function ((class slot-class) slot-name) - (make-std-reader-method-function (class-name class) slot-name)) + (make-std-reader-method-function class slot-name)) (defmethod make-writer-method-function ((class slot-class) slot-name) - (make-std-writer-method-function (class-name class) slot-name)) + (make-std-writer-method-function class slot-name)) (defmethod make-boundp-method-function ((class slot-class) slot-name) - (make-std-boundp-method-function (class-name class) slot-name)) + (make-std-boundp-method-function class slot-name)) (defmethod compatible-meta-class-change-p (class proto-new-class) (eq (class-of class) (class-of proto-new-class))) diff --git a/src/pcl/vector.lisp b/src/pcl/vector.lisp index 902a89e..a9d8160 100644 --- a/src/pcl/vector.lisp +++ b/src/pcl/vector.lisp @@ -306,54 +306,6 @@ (setf (pvref pv i) (cdr map)))))) (incf param)))))) -(defun maybe-expand-accessor-form (form required-parameters slots env) - (let* ((fname (car form)) - #||(len (length form))||# - (gf (if (symbolp fname) - (unencapsulated-fdefinition fname) - (gdefinition fname)))) - (macrolet ((maybe-optimize-reader () - `(let ((parameter - (can-optimize-access1 (cadr form) - required-parameters env))) - (when parameter - (optimize-reader slots parameter gf-name form)))) - (maybe-optimize-writer () - `(let ((parameter - (can-optimize-access1 (caddr form) - required-parameters env))) - (when parameter - (optimize-writer slots parameter gf-name form))))) - (unless (and (consp (cadr form)) - (eq 'instance-accessor-parameter (caadr form))) - (when (and (eq *boot-state* 'complete) - (generic-function-p gf)) - (let ((methods (generic-function-methods gf))) - (when methods - (let* ((gf-name (generic-function-name gf)) - (arg-info (gf-arg-info gf)) - (metatypes (arg-info-metatypes arg-info)) - (nreq (length metatypes)) - (applyp (arg-info-applyp arg-info))) - (when (null applyp) - (cond ((= nreq 1) - (when (some #'standard-reader-method-p methods) - (maybe-optimize-reader))) - ((and (= nreq 2) - (consp gf-name) - (eq (car gf-name) 'setf)) - (when (some #'standard-writer-method-p methods) - (maybe-optimize-writer))))))))))))) - -(defun optimize-generic-function-call (form - required-parameters - env - slots - calls) - (declare (ignore required-parameters env slots calls)) - (or ; (optimize-reader ...)? - form)) - (defun can-optimize-access (form required-parameters env) (let ((type (ecase (car form) (slot-value 'reader) @@ -459,9 +411,16 @@ (defmacro optimized-set-slot-value (form parameter-name optimized-form &environment env) - (if (parameter-modified-p parameter-name env) - `(accessor-set-slot-value ,@(cdr form)) - optimized-form)) + (cond ((safe-code-p env) + ;; Don't optimize slot value setting in safe code, since the + ;; optimized version will fail to catch some type errors + ;; (for example when a subclass declares a tighter type for + ;; the slot than a superclass). + `(safe-set-slot-value ,@(cdr form))) + ((parameter-modified-p parameter-name env) + `(accessor-set-slot-value ,@(cdr form))) + (t + optimized-form))) (defun optimize-slot-boundp (slots sparameter form) (if sparameter @@ -504,18 +463,6 @@ `(accessor-slot-boundp ,@(cdr form)) optimized-form)) -(defun optimize-reader (slots sparameter gf-name form) - (if sparameter - (optimize-accessor-call slots :read sparameter gf-name nil) - form)) - -(defun optimize-writer (slots sparameter gf-name form) - (if sparameter - (destructuring-bind (ignore1 ignore2 new-value) form - (declare (ignore ignore1 ignore2)) - (optimize-accessor-call slots :write sparameter gf-name new-value)) - form)) - ;;; The SLOTS argument is an alist, the CAR of each entry is the name ;;; of a required parameter to the function. The alist is in order, so ;;; the position of an entry in the alist corresponds to the @@ -562,30 +509,6 @@ `(instance-boundp ,pv-offset-form ,parameter ,position ',slot-name ',class))))))) -(defun optimize-accessor-call (slots read/write sparameter gf-name new-value) - (let* ((class (if (consp sparameter) (cdr sparameter) *the-class-t*)) - (parameter (if (consp sparameter) (car sparameter) sparameter)) - (parameter-entry (assq parameter slots)) - (name (case read/write - (:read `(reader ,gf-name)) - (:write `(writer ,gf-name)))) - (slot-entry (assoc name (cdr parameter-entry) :test #'equal)) - (position (posq parameter-entry slots)) - (pv-offset-form (list 'pv-offset ''.PV-OFFSET.))) - (unless parameter-entry - (error "slot optimization bewilderment: O-A-C")) - (unless slot-entry - (setq slot-entry (list name)) - (push slot-entry (cdr parameter-entry))) - (push pv-offset-form (cdr slot-entry)) - (ecase read/write - (:read - `(instance-reader ,pv-offset-form ,parameter ,position ,gf-name ',class)) - (:write - `(let ((.new-value. ,new-value)) - (instance-writer ,pv-offset-form ,parameter ,position ,gf-name ',class - .new-value.)))))) - (defvar *unspecific-arg* '..unspecific-arg..) (defun optimize-gf-call-internal (form slots env) @@ -675,10 +598,10 @@ (eq *boot-state* 'complete) (not (slot-accessor-std-p slotd type))))) -(defmacro instance-read-internal (pv slots pv-offset default &optional type) - (unless (member type '(nil :instance :class :default)) - (error "illegal type argument to ~S: ~S" 'instance-read-internal type)) - (if (eq type :default) +(defmacro instance-read-internal (pv slots pv-offset default &optional kind) + (unless (member kind '(nil :instance :class :default)) + (error "illegal kind argument to ~S: ~S" 'instance-read-internal kind)) + (if (eq kind :default) default (let* ((index (gensym)) (value index)) @@ -696,11 +619,11 @@ ;; to shut it up. (see also mail Rudi ;; Schlatte sbcl-devel 2003-09-21) -- CSR, ;; 2003-11-30 - ,@(when (or (null type) (eq type :instance)) + ,@(when (or (null kind) (eq kind :instance)) `((fixnum (and ,slots ; KLUDGE (clos-slots-ref ,slots ,index))))) - ,@(when (or (null type) (eq type :class)) + ,@(when (or (null kind) (eq kind :class)) `((cons (cdr ,index)))) (t +slot-unbound+))) (if (eq ,value +slot-unbound+) @@ -715,28 +638,21 @@ ,(if (generate-fast-class-slot-access-p class slot-name) :class :instance)))) -(defmacro instance-reader (pv-offset parameter position gf-name class) - (declare (ignore class)) - `(instance-read-internal .pv. ,(slot-vector-symbol position) - ,pv-offset - (,gf-name (instance-accessor-parameter ,parameter)) - :instance)) - (defmacro instance-write-internal (pv slots pv-offset new-value default - &optional type) - (unless (member type '(nil :instance :class :default)) - (error "illegal type argument to ~S: ~S" 'instance-write-internal type)) - (if (eq type :default) + &optional kind) + (unless (member kind '(nil :instance :class :default)) + (error "illegal kind argument to ~S: ~S" 'instance-write-internal kind)) + (if (eq kind :default) default (let* ((index (gensym))) `(locally (declare #.*optimize-speed*) (let ((,index (pvref ,pv ,pv-offset))) (typecase ,index - ,@(when (or (null type) (eq type :instance)) + ,@(when (or (null kind) (eq kind :instance)) `((fixnum (and ,slots (setf (clos-slots-ref ,slots ,index) ,new-value))))) - ,@(when (or (null type) (eq type :class)) + ,@(when (or (null kind) (eq kind :class)) `((cons (setf (cdr ,index) ,new-value)))) (t ,default))))))) @@ -754,37 +670,21 @@ ,(if (generate-fast-class-slot-access-p class slot-name) :class :instance)))) -(defmacro instance-writer (pv-offset - parameter - position - gf-name - class - new-value) - (declare (ignore class)) - `(instance-write-internal .pv. ,(slot-vector-symbol position) - ,pv-offset ,new-value - (,(if (consp gf-name) - (get-setf-fun-name gf-name) - gf-name) - (instance-accessor-parameter ,parameter) - ,new-value) - :instance)) - (defmacro instance-boundp-internal (pv slots pv-offset default - &optional type) - (unless (member type '(nil :instance :class :default)) - (error "illegal type argument to ~S: ~S" 'instance-boundp-internal type)) - (if (eq type :default) + &optional kind) + (unless (member kind '(nil :instance :class :default)) + (error "illegal kind argument to ~S: ~S" 'instance-boundp-internal kind)) + (if (eq kind :default) default (let* ((index (gensym))) `(locally (declare #.*optimize-speed*) (let ((,index (pvref ,pv ,pv-offset))) (typecase ,index - ,@(when (or (null type) (eq type :instance)) + ,@(when (or (null kind) (eq kind :instance)) `((fixnum (not (and ,slots (eq (clos-slots-ref ,slots ,index) +slot-unbound+)))))) - ,@(when (or (null type) (eq type :class)) + ,@(when (or (null kind) (eq kind :class)) `((cons (not (eq (cdr ,index) +slot-unbound+))))) (t ,default))))))) @@ -1235,3 +1135,4 @@ when snl collect w into result finally (return (if (cdr result) result (car result))))) + diff --git a/src/pcl/walk.lisp b/src/pcl/walk.lisp index ff5c160..5f44953 100644 --- a/src/pcl/walk.lisp +++ b/src/pcl/walk.lisp @@ -293,6 +293,7 @@ (defun var-globally-special-p (symbol) (eq (info :variable :kind symbol) :special)) + ;;;; handling of special forms @@ -702,14 +703,15 @@ (relist* form let/let* walked-bindings walked-body)))) -(defun walk-locally (form context env) +(defun walk-locally (form context old-env) (declare (ignore context)) - (let* ((locally (car form)) - (body (cdr form)) - (walked-body - (walk-declarations body #'walk-repeat-eval env))) - (relist* - form locally walked-body))) + (walker-environment-bind (new-env old-env) + (let* ((locally (car form)) + (body (cdr form)) + (walked-body + (walk-declarations body #'walk-repeat-eval new-env))) + (relist* + form locally walked-body)))) (defun walk-multiple-value-setq (form context env) (let ((vars (cadr form))) @@ -873,62 +875,65 @@ (walk-tagbody-1 (cdr form) context env)))) (defun walk-macrolet (form context old-env) - (walker-environment-bind (macro-env - nil - :walk-function (env-walk-function old-env)) - (labels ((walk-definitions (definitions) - (and definitions - (let ((definition (car definitions))) - (recons definitions - (relist* definition - (car definition) - (walk-arglist (cadr definition) - context - macro-env - t) - (walk-declarations (cddr definition) - #'walk-repeat-eval - macro-env)) - (walk-definitions (cdr definitions))))))) - (with-new-definition-in-environment (new-env old-env form) - (relist* form - (car form) - (walk-definitions (cadr form)) - (walk-declarations (cddr form) - #'walk-repeat-eval - new-env)))))) + (walker-environment-bind (old-env old-env) + (walker-environment-bind (macro-env + nil + :walk-function (env-walk-function old-env)) + (labels ((walk-definitions (definitions) + (and definitions + (let ((definition (car definitions))) + (recons definitions + (relist* definition + (car definition) + (walk-arglist (cadr definition) + context + macro-env + t) + (walk-declarations (cddr definition) + #'walk-repeat-eval + macro-env)) + (walk-definitions (cdr definitions))))))) + (with-new-definition-in-environment (new-env old-env form) + (relist* form + (car form) + (walk-definitions (cadr form)) + (walk-declarations (cddr form) + #'walk-repeat-eval + new-env))))))) (defun walk-flet (form context old-env) - (labels ((walk-definitions (definitions) - (if (null definitions) - () - (recons definitions - (walk-lambda (car definitions) context old-env) - (walk-definitions (cdr definitions)))))) - (recons form - (car form) - (recons (cdr form) - (walk-definitions (cadr form)) - (with-new-definition-in-environment (new-env old-env form) - (walk-declarations (cddr form) - #'walk-repeat-eval - new-env)))))) - -(defun walk-labels (form context old-env) - (with-new-definition-in-environment (new-env old-env form) + (walker-environment-bind (old-env old-env) (labels ((walk-definitions (definitions) (if (null definitions) () (recons definitions - (walk-lambda (car definitions) context new-env) + (walk-lambda (car definitions) context old-env) (walk-definitions (cdr definitions)))))) (recons form (car form) (recons (cdr form) (walk-definitions (cadr form)) - (walk-declarations (cddr form) - #'walk-repeat-eval - new-env)))))) + (with-new-definition-in-environment (new-env old-env form) + (walk-declarations (cddr form) + #'walk-repeat-eval + new-env))))))) + +(defun walk-labels (form context old-env) + (walker-environment-bind (old-env old-env) + (with-new-definition-in-environment (new-env old-env form) + (labels ((walk-definitions (definitions) + (if (null definitions) + () + (recons definitions + (walk-lambda (car definitions) context new-env) + (walk-definitions (cdr definitions)))))) + (recons form + (car form) + (recons (cdr form) + (walk-definitions (cadr form)) + (walk-declarations (cddr form) + #'walk-repeat-eval + new-env))))))) (defun walk-if (form context env) (destructuring-bind (if predicate arm1 &optional arm2) form diff --git a/tests/clos-typechecking.impure.lisp b/tests/clos-typechecking.impure.lisp new file mode 100644 index 0000000..f72cb67 --- /dev/null +++ b/tests/clos-typechecking.impure.lisp @@ -0,0 +1,234 @@ +;;;; This file is for testing typechecking of writes to CLOS object slots +;;;; for code compiled with a (SAFETY 3) optimization policy. + +;;;; 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. + +(shadow 'slot) + +(declaim (optimize safety)) + +(defclass foo () + ((slot :initarg :slot :type fixnum :accessor slot))) +(defclass foo/gf (sb-mop:standard-generic-function) + ((slot/gf :initarg :slot/gf :type fixnum :accessor slot/gf)) + (:metaclass sb-mop:funcallable-standard-class)) +(defmethod succeed/sv ((x foo)) + (setf (slot-value x 'slot) 1)) +(defmethod fail/sv ((x foo)) + (setf (slot-value x 'slot) t)) +(defmethod succeed/acc ((x foo)) + (setf (slot x) 1)) +(defmethod fail/acc ((x foo)) + (setf (slot x) t)) +(defmethod succeed/sv/gf ((x foo/gf)) + (setf (slot-value x 'slot/gf) 1)) +(defmethod fail/sv/gf ((x foo/gf)) + (setf (slot-value x 'slot/gf) t)) +(defmethod succeed/acc/gf ((x foo/gf)) + (setf (slot/gf x) 1)) +(defmethod fail/acc/gf ((x foo/gf)) + (setf (slot/gf x) t)) +(defvar *t* t) +(defvar *one* 1) + +;; evaluator +(with-test (:name (:evaluator)) + (eval '(setf (slot-value (make-instance 'foo) 'slot) 1)) + (assert (raises-error? (eval '(setf (slot-value (make-instance 'foo) 'slot) t)) + type-error)) + (eval '(setf (slot (make-instance 'foo)) 1)) + (assert (raises-error? (eval '(setf (slot (make-instance 'foo)) t)) + type-error)) + (eval '(succeed/sv (make-instance 'foo))) + (assert (raises-error? (eval '(fail/sv (make-instance 'foo))) + type-error)) + (eval '(succeed/acc (make-instance 'foo))) + (assert (raises-error? (eval '(fail/acc (make-instance 'foo))) + type-error)) + (eval '(make-instance 'foo :slot 1)) + (assert (raises-error? (eval '(make-instance 'foo :slot t)) + type-error)) + (eval '(make-instance 'foo :slot *one*)) + (assert (raises-error? (eval '(make-instance 'foo :slot *t*)) + type-error))) +;; evaluator/gf +(with-test (:name (:evaluator/gf)) + (eval '(setf (slot-value (make-instance 'foo/gf) 'slot/gf) 1)) + (assert (raises-error? + (eval '(setf (slot-value (make-instance 'foo/gf) 'slot/gf) t)) + type-error)) + (eval '(setf (slot/gf (make-instance 'foo/gf)) 1)) + (assert (raises-error? (eval '(setf (slot/gf (make-instance 'foo/gf)) t)) + type-error)) + (eval '(succeed/sv/gf (make-instance 'foo/gf))) + (assert (raises-error? (eval '(fail/sv/gf (make-instance 'foo/gf))) + type-error)) + (eval '(succeed/acc/gf (make-instance 'foo/gf))) + (assert (raises-error? (eval '(fail/acc/gf (make-instance 'foo/gf))) + type-error)) + (eval '(make-instance 'foo/gf :slot/gf 1)) + (assert (raises-error? (eval '(make-instance 'foo/gf :slot/gf t)) + type-error)) + (eval '(make-instance 'foo/gf :slot/gf *one*)) + (assert (raises-error? (eval '(make-instance 'foo/gf :slot/gf *t*)) + type-error))) + +;; compiler +(with-test (:name (:compiler)) + (funcall (compile nil '(lambda () + (setf (slot-value (make-instance 'foo) 'slot) 1)))) + (funcall (compile nil '(lambda () (setf (slot (make-instance 'foo)) 1)))) + (assert (raises-error? + (funcall + (compile nil '(lambda () (setf (slot (make-instance 'foo)) t)))) + type-error)) + (funcall (compile nil '(lambda () (succeed/sv (make-instance 'foo))))) + (assert (raises-error? + (funcall (compile nil '(lambda () (fail/sv (make-instance 'foo))))) + type-error)) + (funcall (compile nil '(lambda () (succeed/acc (make-instance 'foo))))) + (assert (raises-error? + (funcall (compile nil '(lambda () (fail/acc (make-instance 'foo))))) + type-error)) + (funcall (compile nil '(lambda () (make-instance 'foo :slot 1)))) + (assert (raises-error? + (funcall (compile nil '(lambda () (make-instance 'foo :slot t)))) + type-error)) + (funcall (compile nil '(lambda () (make-instance 'foo :slot *one*)))) + (assert (raises-error? + (funcall (compile nil '(lambda () (make-instance 'foo :slot *t*)))) + type-error))) + +(with-test (:name (:compiler :setf :slot-value)) + (assert (raises-error? + (funcall + (compile nil '(lambda () + (setf (slot-value (make-instance 'foo) 'slot) t)))) + type-error))) + +; compiler/gf +(with-test (:name (:compiler/gf)) + (funcall (compile nil + '(lambda () + (setf (slot-value (make-instance 'foo/gf) 'slot/gf) 1)))) + (funcall (compile nil '(lambda () (setf (slot/gf (make-instance 'foo/gf)) 1)))) + (assert (raises-error? + (funcall + (compile nil + '(lambda () (setf (slot/gf (make-instance 'foo/gf)) t)))) + type-error)) + (funcall (compile nil '(lambda () (succeed/sv/gf (make-instance 'foo/gf))))) + (assert (raises-error? + (funcall (compile nil '(lambda () + (fail/sv/gf (make-instance 'foo/gf))))) + type-error)) + (funcall (compile nil '(lambda () (succeed/acc/gf (make-instance 'foo/gf))))) + (assert (raises-error? + (funcall (compile nil '(lambda () + (fail/acc/gf (make-instance 'foo/gf))))) + type-error)) + (funcall (compile nil '(lambda () (make-instance 'foo/gf :slot/gf 1)))) + (assert (raises-error? + (funcall (compile nil '(lambda () + (make-instance 'foo/gf :slot/gf t)))) + type-error)) + (funcall (compile nil '(lambda () (make-instance 'foo/gf :slot/gf *one*)))) + (assert (raises-error? + (funcall (compile nil '(lambda () + (make-instance 'foo/gf :slot/gf *t*)))) + type-error))) + +(with-test (:name (:compiler/gf :setf :slot-value)) + (assert (raises-error? + (funcall + (compile nil + '(lambda () + (setf (slot-value (make-instance 'foo/gf) 'slot/gf) t)))) + type-error))) + + +(with-test (:name (:slot-inheritance :slot-value :float/single-float)) + (defclass a () ((slot1 :initform 0.0 :type float))) + (defclass b (a) ((slot1 :initform 0.0 :type single-float))) + (defmethod inheritance-test ((a a)) (setf (slot-value a 'slot1) 1d0)) + (inheritance-test (make-instance 'a)) + (assert (raises-error? (inheritance-test (make-instance 'b)) type-error))) + +(with-test (:name (:slot-inheritance :slot-value :t/single-float)) + (defclass a () ((slot1 :initform 0.0))) + (defclass b (a) ((slot1 :initform 0.0 :type single-float))) + (defmethod inheritance-test ((a a)) (setf (slot-value a 'slot1) 1d0)) + (inheritance-test (make-instance 'a)) + (assert (raises-error? (inheritance-test (make-instance 'b)) type-error))) + +(with-test (:name (:slot-inheritance :writer :float/single-float)) + (defclass a () ((slot1 :initform 0.0 :type float :accessor slot1-of))) + (defclass b (a) ((slot1 :initform 0.0 :type single-float))) + (defmethod inheritance-test ((a a)) (setf (slot1-of a) 1d0)) + (inheritance-test (make-instance 'a)) + (assert (raises-error? (inheritance-test (make-instance 'b)) type-error))) + +(with-test (:name (:slot-inheritance :writer :float/single-float)) + (defclass a () ((slot1 :initform 0.0 :accessor slot1-of))) + (defclass b (a) ((slot1 :initform 0.0 :type single-float))) + (defmethod inheritance-test ((a a)) (setf (slot1-of a) 1d0)) + (inheritance-test (make-instance 'a)) + (assert (raises-error? (inheritance-test (make-instance 'b)) type-error))) + +(with-test (:name (:slot-inheritance :type-intersection)) + (defclass a* () + ((slot1 :initform 1 + :initarg :slot1 + :accessor slot1-of + :type fixnum))) + (defclass b* () + ((slot1 :initform 1 + :initarg :slot1 + :accessor slot1-of + :type unsigned-byte))) + (defclass c* (a* b*) + ()) + (setf (slot1-of (make-instance 'a*)) -1) + (setf (slot1-of (make-instance 'b*)) (1+ most-positive-fixnum)) + (setf (slot1-of (make-instance 'c*)) 1) + (assert (raises-error? (setf (slot1-of (make-instance 'c*)) -1) + type-error)) + (assert (raises-error? (setf (slot1-of (make-instance 'c*)) + (1+ most-positive-fixnum)) + type-error)) + (assert (raises-error? (make-instance 'c* :slot1 -1) + type-error)) + (assert (raises-error? (make-instance 'c* :slot1 (1+ most-positive-fixnum)) + type-error))) + +(defclass a () + ((slot1 :initform nil + :initarg :slot1 + :accessor slot1-of + :type (or null function)))) +(defclass b (a) + ((slot1 :initform nil + :initarg :slot1 + :accessor slot1-of + :type (or null (function (fixnum) fixnum))))) + +(with-test (:name (:type :function)) + (setf (slot1-of (make-instance 'a)) (lambda () 1)) + (setf (slot1-of (make-instance 'b)) (lambda () 1)) + (assert (raises-error? (setf (slot1-of (make-instance 'a)) 1) + type-error)) + (assert (raises-error? (setf (slot1-of (make-instance 'b)) 1) + type-error)) + (make-instance 'a :slot1 (lambda () 1)) + (make-instance 'b :slot1 (lambda () 1))) + + diff --git a/tests/mop.impure-cload.lisp b/tests/mop.impure-cload.lisp index 4d98521..5299d4f 100644 --- a/tests/mop.impure-cload.lisp +++ b/tests/mop.impure-cload.lisp @@ -23,7 +23,7 @@ ;;; A distilled test case from cmucl-imp for Kevin Rosenberg's ;;; hyperobject. Fix from Gerd Moellmann. (defclass hyperobject-class (standard-class) - ((user-name :initarg :user-name :type string :initform nil + ((user-name :initarg :user-name :type (or null string) :initform nil :accessor user-name :documentation "User name for class"))) diff --git a/tests/type.impure.lisp b/tests/type.impure.lisp index 73301f0..8ab2a97 100644 --- a/tests/type.impure.lisp +++ b/tests/type.impure.lisp @@ -430,11 +430,11 @@ ;;; confusing. (with-test (:name (:ctor :typep-function)) (assert (eval '(typep (sb-pcl::ensure-ctor - (list 'sb-pcl::ctor (gensym)) nil nil) + (list 'sb-pcl::ctor (gensym)) nil nil nil) 'function)))) (with-test (:name (:ctor :functionp)) (assert (functionp (sb-pcl::ensure-ctor - (list 'sb-pcl::ctor (gensym)) nil nil)))) + (list 'sb-pcl::ctor (gensym)) nil nil nil)))) ;;; from PFD ansi-tests (let ((t1 '(cons (cons (cons (real -744833699 -744833699) cons) diff --git a/version.lisp-expr b/version.lisp-expr index ab778cc..78e913e 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".) -"0.9.18.37" +"0.9.18.38" -- 1.7.10.4