From 9bdd2579f980573a74daabe03120ed64b1733b11 Mon Sep 17 00:00:00 2001 From: Jan Moringen Date: Fri, 5 Apr 2013 12:31:06 +0200 Subject: [PATCH] Use AMOP representation of canonicalized default initargs for conditions This fixes two issues: 1. CLASS-DIRECT-DEFAULT-INITARGS did not work for condition classes (bug 1164970) 2. Constant functions as default initargs of condition classes did not work correctly (bug 539517) The following things have been changed: * CONDITION-CLASSOID-DEFAULT-INITARGS is now called CONDITION-CLASSOID-DIRECT-DEFAULT-INITARGS to better reflect its purpose. * Previously, default initargs of condition classes where stored in a plist the values of which where constant initforms or initfunctions. Now default initargs of condition classes are always of the form (INITARG INITFORM THUNK) as described in AMOP. * The SHARED-INITIALIZED :AFTER CONDITION-CLASS T method now stores the direct default initargs in the class plist. These are now of the correct form as described in the previous bullet point. * The DOPLIST macro used to be defined in src/pcl/macros.lisp. It is now in src/code/early-extensions.lisp and exported from SB-INT. This was necessary to use DOPLIST in src/code/condition.lisp. * Unit test for both problems have been added. fixes lp#539517, fixes lp#1164970 --- NEWS | 4 +++ package-data-list.lisp-expr | 2 +- src/code/condition.lisp | 62 +++++++++++++++++++--------------------- src/code/early-extensions.lisp | 14 ++++++++- src/pcl/macros.lisp | 9 ------ src/pcl/std-class.lisp | 22 ++++++++------ tests/condition.impure.lisp | 51 +++++++++++++++++++++++++++++++++ 7 files changed, 112 insertions(+), 52 deletions(-) diff --git a/NEWS b/NEWS index 0c96a2a..b0fc7b6 100644 --- a/NEWS +++ b/NEWS @@ -1,5 +1,9 @@ ;;;; -*- coding: utf-8; fill-column: 78 -*- changes relative to sbcl-1.1.6 + * bug fix: CLASS-DIRECT-DEFAULT-INITARGS now works for condition classes + (lp#1164970) + * bug fix: function constants now work as initforms and default initarg + values of conditions (lp#539517) * bug fix: svref/(setf svref) on symbol macros don't crash the compiler anymore. (Minimal test case provided by James M. Lawrence on sbcl-devel) * bug fix: no more bogus ## references when pretty printing backquoted diff --git a/package-data-list.lisp-expr b/package-data-list.lisp-expr index b8eb791..4a88b7f 100644 --- a/package-data-list.lisp-expr +++ b/package-data-list.lisp-expr @@ -1073,7 +1073,7 @@ possibly temporariliy, because it might be used internally." ;; ..and macros.. "COLLECT" - "DO-ANONYMOUS" "DOHASH" "DOVECTOR" + "DO-ANONYMOUS" "DOVECTOR" "DOHASH" "DOPLIST" "NAMED-LET" "ONCE-ONLY" "DEFENUM" diff --git a/src/code/condition.lisp b/src/code/condition.lisp index faa0447..c1dc599 100644 --- a/src/code/condition.lisp +++ b/src/code/condition.lisp @@ -31,8 +31,13 @@ (class-slots nil :type list) ;; report function or NIL (report nil :type (or function null)) - ;; list of alternating initargs and initforms - (default-initargs () :type list) + ;; list of specifications of the form + ;; + ;; (INITARG INITFORM THUNK) + ;; + ;; where THUNK, when called without arguments, returns the value for + ;; INITARG. + (direct-default-initargs () :type list) ;; class precedence list as a list of CLASS objects, with all ;; non-CONDITION classes removed (cpl () :type list) @@ -173,16 +178,17 @@ (defun find-slot-default (class slot) (let ((initargs (condition-slot-initargs slot)) (cpl (condition-classoid-cpl class))) + ;; When CLASS or a superclass has a default initarg for SLOT, use + ;; that. (dolist (class cpl) - (let ((default-initargs (condition-classoid-default-initargs class))) + (let ((direct-default-initargs + (condition-classoid-direct-default-initargs class))) (dolist (initarg initargs) - (let ((val (getf default-initargs initarg *empty-condition-slot*))) - (unless (eq val *empty-condition-slot*) - (return-from find-slot-default - (if (functionp val) - (funcall val) - val))))))) + (let ((initfunction (third (assoc initarg direct-default-initargs)))) + (when initfunction + (return-from find-slot-default (funcall initfunction))))))) + ;; Otherwise use the initform of SLOT, if there is one. (if (condition-slot-initform-p slot) (let ((initform (condition-slot-initform slot))) (if (functionp initform) @@ -257,7 +263,7 @@ :datum type :expected-type 'condition-class :format-control - "~s doesn't designate a condition class." + "~s does not designate a condition class." :format-arguments (list type))))) (res (make-condition-object args))) (setf (%instance-layout res) (classoid-layout class)) @@ -385,7 +391,7 @@ report)) (defun %define-condition (name parent-types layout slots documentation - default-initargs all-readers all-writers + direct-default-initargs all-readers all-writers source-location) (with-single-package-locked-error (:symbol name "defining ~A as a condition") @@ -394,9 +400,9 @@ (setf (layout-source-location layout) source-location)) (let ((class (find-classoid name))) - (setf (condition-classoid-slots class) slots) - (setf (condition-classoid-default-initargs class) default-initargs) - (setf (fdocumentation name 'type) documentation) + (setf (condition-classoid-slots class) slots + (condition-classoid-direct-default-initargs class) direct-default-initargs + (fdocumentation name 'type) documentation) (dolist (slot slots) @@ -412,8 +418,8 @@ (let ((eslots (compute-effective-slots class)) (e-def-initargs (reduce #'append - (mapcar #'condition-classoid-default-initargs - (condition-classoid-cpl class))))) + (mapcar #'condition-classoid-direct-default-initargs + (condition-classoid-cpl class))))) (dolist (slot eslots) (ecase (condition-slot-allocation slot) (:class @@ -430,7 +436,7 @@ (setf (condition-slot-allocation slot) :instance) (when (or (functionp (condition-slot-initform slot)) (dolist (initarg (condition-slot-initargs slot) nil) - (when (functionp (getf e-def-initargs initarg)) + (when (functionp (third (assoc initarg e-def-initargs))) (return t)))) (push slot (condition-classoid-hairy-slots class))))))) (when (boundp '*define-condition-hooks*) @@ -462,7 +468,7 @@ (layout (find-condition-layout name parent-types)) (documentation nil) (report nil) - (default-initargs ())) + (direct-default-initargs ())) (collect ((slots) (all-readers nil append) (all-writers nil append)) @@ -518,10 +524,8 @@ :writers ',(writers) :initform-p ',initform-p :documentation ',documentation - :initform - ,(if (sb!xc:constantp initform) - `',(constant-form-value initform) - `#'(lambda () ,initform))))))) + :initform ,(when initform-p + `#'(lambda () ,initform))))))) (dolist (option options) (unless (consp option) @@ -538,15 +542,9 @@ `#'(lambda (condition stream) (funcall #',arg condition stream)))))) (:default-initargs - (do ((initargs (rest option) (cddr initargs))) - ((endp initargs)) - (let ((val (second initargs))) - (setq default-initargs - (list* `',(first initargs) - (if (sb!xc:constantp val) - `',(constant-form-value val) - `#'(lambda () ,val)) - default-initargs))))) + (doplist (initarg initform) (rest option) + (push ``(,',initarg ,',initform ,#'(lambda () ,initform)) + direct-default-initargs))) (t (error "unknown option: ~S" (first option))))) @@ -560,7 +558,7 @@ ',layout (list ,@(slots)) ,documentation - (list ,@default-initargs) + (list ,@direct-default-initargs) ',(all-readers) ',(all-writers) (sb!c:source-location)) diff --git a/src/code/early-extensions.lisp b/src/code/early-extensions.lisp index 7db471f..028707c 100644 --- a/src/code/early-extensions.lisp +++ b/src/code/early-extensions.lisp @@ -430,7 +430,6 @@ (eq (car clause) 'ignore)))) (cdr decl)))) decls)) - ;;; just like DOLIST, but with one-dimensional arrays (defmacro dovector ((elt vector &optional result) &body body) (multiple-value-bind (forms decls) (parse-body body :doc-string-allowed nil) @@ -464,6 +463,19 @@ `(with-locked-system-table (,n-table) ,iter-form) iter-form)))))) + +;;; Executes BODY for all entries of PLIST with KEY and VALUE bound to +;;; the respective keys and values. +(defmacro doplist ((key val) plist &body body) + (with-unique-names (tail) + `(let ((,tail ,plist) ,key ,val) + (loop (when (null ,tail) (return nil)) + (setq ,key (pop ,tail)) + (when (null ,tail) + (error "malformed plist, odd number of elements")) + (setq ,val (pop ,tail)) + (progn ,@body))))) + ;;;; hash cache utility diff --git a/src/pcl/macros.lisp b/src/pcl/macros.lisp index 39379d2..437e802 100644 --- a/src/pcl/macros.lisp +++ b/src/pcl/macros.lisp @@ -47,15 +47,6 @@ (/show "pcl/macros.lisp 85") -(defmacro doplist ((key val) plist &body body) - `(let ((.plist-tail. ,plist) ,key ,val) - (loop (when (null .plist-tail.) (return nil)) - (setq ,key (pop .plist-tail.)) - (when (null .plist-tail.) - (error "malformed plist, odd number of elements")) - (setq ,val (pop .plist-tail.)) - (progn ,@body)))) - (/show "pcl/macros.lisp 101") (defmacro dolist-carefully ((var list improper-list-handler) &body body) diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index c1e6af3..1ac4eb4 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -567,18 +567,22 @@ &key direct-slots direct-superclasses) (declare (ignore slot-names)) (let ((classoid (find-classoid (slot-value class 'name)))) - (with-slots (wrapper %class-precedence-list cpl-available-p - prototype (direct-supers direct-superclasses)) + (with-slots (wrapper + %class-precedence-list cpl-available-p finalized-p + prototype (direct-supers direct-superclasses) + plist) class (setf (slot-value class 'direct-slots) (mapcar (lambda (pl) (make-direct-slotd class pl)) - direct-slots)) - (setf (slot-value class 'finalized-p) t) - (setf (classoid-pcl-class classoid) class) - (setq direct-supers direct-superclasses) - (setq wrapper (classoid-layout classoid)) - (setq %class-precedence-list (compute-class-precedence-list class)) - (setq cpl-available-p t) + direct-slots) + finalized-p t + (classoid-pcl-class classoid) class + direct-supers direct-superclasses + wrapper (classoid-layout classoid) + %class-precedence-list (compute-class-precedence-list class) + cpl-available-p t + (getf plist 'direct-default-initargs) + (sb-kernel::condition-classoid-direct-default-initargs classoid)) (add-direct-subclasses class direct-superclasses) (let ((slots (compute-slots class))) (setf (slot-value class 'slots) slots) diff --git a/tests/condition.impure.lisp b/tests/condition.impure.lisp index 2bf5976..ae332c3 100644 --- a/tests/condition.impure.lisp +++ b/tests/condition.impure.lisp @@ -122,6 +122,7 @@ (return-from restart-test-finds-restarts 42)) :test-function (lambda (condition) + (declare (ignore condition)) (find-restart 'qux)))) (when (find-restart 'bar) (invoke-restart 'bar)))) @@ -142,3 +143,53 @@ (assert (eq (eval `(define-condition ,name () ())) name)))) + +;;; bug-1164970 + +(define-condition condition-with-default-initargs (condition) + () + (:default-initargs :foo 1)) + +(with-test (:name (sb-mop:class-direct-default-initargs :for-condition-class + :bug-1164970)) + ;; CLASS-DIRECT-DEFAULT-INITARGS used to return nil for all + ;; condition classes. + (let ((initargs (sb-mop:class-direct-default-initargs + (find-class 'condition-with-default-initargs)))) + (assert (equal (subseq (first initargs) 0 2) '(:foo 1))))) + +;;; bug-539517 + +(defconstant +error-when-called+ (lambda () (error "oops"))) + +(define-condition condition-with-constant-function-initarg () + ((foo :initarg :foo + :reader condition-with-constant-function-initarg-foo)) + (:default-initargs :foo +error-when-called+)) + +(with-test (:name (:condition-with-constant-function-initarg :bug-539517)) + ;; The default initarg handling for condition classes used to + ;; confuse constant functions (thus +ERROR-WHEN-CALLED+) and + ;; initfunctions. This lead to +ERROR-WHEN-CALLED+ being called as + ;; if it was an initfunction. + (assert (functionp + (condition-with-constant-function-initarg-foo + (make-condition 'condition-with-constant-function-initarg)))) + (assert (functionp + (condition-with-constant-function-initarg-foo + (make-instance 'condition-with-constant-function-initarg))))) + +;; Same problem + +(define-condition condition-with-constant-function-initform () + ((foo :initarg :foo + :reader condition-with-constant-function-initform-foo + :initform +error-when-called+))) + +(with-test (:name (:condition-with-constant-function-slot-initform)) + (assert (functionp + (condition-with-constant-function-initform-foo + (make-condition 'condition-with-constant-function-initform)))) + (assert (functionp + (condition-with-constant-function-initform-foo + (make-instance 'condition-with-constant-function-initform))))) -- 1.7.10.4