From ed3295bc583cd14104130441e9ff1ad40fa5e484 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Mon, 16 Jan 2006 15:10:24 +0000 Subject: [PATCH] 0.9.8.41: Fix the mop/sb-posix/interface.pure.lisp/PCL metacircularity problem. ... treat GF-DFUN-STATE and (SETF GF-DFUN-STATE) specially. ... thanks to everyone who thought very hard about it! ... also make interface.pure.lisp actually pure. --- NEWS | 2 ++ src/pcl/boot.lisp | 15 +++++++++++--- tests/interface.impure.lisp | 44 +++++++++++++++++++++++++++++++++++++++ tests/interface.pure.lisp | 43 -------------------------------------- tests/mop-11.impure-cload.lisp | 45 ++++++++++++++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 6 files changed, 104 insertions(+), 47 deletions(-) create mode 100644 tests/mop-11.impure-cload.lisp diff --git a/NEWS b/NEWS index 289d8c3..10eeab1 100644 --- a/NEWS +++ b/NEWS @@ -9,6 +9,8 @@ changes in sbcl-0.9.9 relative to sbcl-0.9.8: * bug fix: interrupt handling on NetBSD (thanks to Richard M Kreuter) * bug fix: saving a core corrupted callbacks on x86/x86-64 + * bug fix: closed a loophole in metacircularity detection and + grounding in the PCL implementation of CLOS. * optimization: major improvements to GC efficiency on GENCGC platforms * optimization: faster implementation of EQUAL * optimization: emit more efficient opcodes for some common diff --git a/src/pcl/boot.lisp b/src/pcl/boot.lisp index 1d25ea5..e87e2ee 100644 --- a/src/pcl/boot.lisp +++ b/src/pcl/boot.lisp @@ -1922,14 +1922,21 @@ bootstrapping. (list* dfun cache info) dfun))) (if (eq *boot-state* 'complete) - (setf (gf-dfun-state gf) new-state) + (if (eq (class-of gf) *the-class-standard-generic-function*) + ;; break metacircles: see sbcl-devel 2006-01-15 and #lisp + ;; IRC logs 2006-01-16 for the hilarity. + (setf (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*) + new-state) + (setf (gf-dfun-state gf) new-state)) (setf (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*) new-state))) dfun) (defun gf-dfun-cache (gf) (let ((state (if (eq *boot-state* 'complete) - (gf-dfun-state gf) + (if (eq (class-of gf) *the-class-standard-generic-function*) + (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*) + (gf-dfun-state gf)) (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*)))) (typecase state (function nil) @@ -1937,7 +1944,9 @@ bootstrapping. (defun gf-dfun-info (gf) (let ((state (if (eq *boot-state* 'complete) - (gf-dfun-state gf) + (if (eq (class-of gf) *the-class-standard-generic-function*) + (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*) + (gf-dfun-state gf)) (clos-slots-ref (get-slots gf) *sgf-dfun-state-index*)))) (typecase state (function nil) diff --git a/tests/interface.impure.lisp b/tests/interface.impure.lisp index 406dfba..ea21552 100644 --- a/tests/interface.impure.lisp +++ b/tests/interface.impure.lisp @@ -35,4 +35,48 @@ (let ((x 1)) (defun disassemble-closure (y) (if y (setq x y) x))) (disassemble 'disassemble-closure) +;;; support for DESCRIBE tests +(defstruct to-be-described a b) +(defclass forward-describe-class (forward-describe-ref) (a)) + +;;; DESCRIBE should run without signalling an error. +(describe (make-to-be-described)) +(describe 12) +(describe "a string") +(describe 'symbolism) +(describe (find-package :cl)) +(describe '(a list)) +(describe #(a vector)) + +;;; The DESCRIBE-OBJECT methods for built-in CL stuff should do +;;; FRESH-LINE and TERPRI neatly. +(dolist (i (list (make-to-be-described :a 14) 12 "a string" + #0a0 #(1 2 3) #2a((1 2) (3 4)) 'sym :keyword + (find-package :keyword) (list 1 2 3) + nil (cons 1 2) (make-hash-table) + (let ((h (make-hash-table))) + (setf (gethash 10 h) 100 + (gethash 11 h) 121) + h) + (make-condition 'simple-error) + (make-condition 'simple-error :format-control "fc") + #'car #'make-to-be-described (lambda (x) (+ x 11)) + (constantly 'foo) #'(setf to-be-described-a) + #'describe-object (find-class 'to-be-described) + (find-class 'forward-describe-class) + (find-class 'forward-describe-ref) (find-class 'cons))) + (let ((s (with-output-to-string (s) + (write-char #\x s) + (describe i s)))) + (unless (and (char= #\x (char s 0)) + ;; one leading #\NEWLINE from FRESH-LINE or the like, no more + (char= #\newline (char s 1)) + (char/= #\newline (char s 2)) + ;; one trailing #\NEWLINE from TERPRI or the like, no more + (let ((n (length s))) + (and (char= #\newline (char s (- n 1))) + (char/= #\newline (char s (- n 2)))))) + (error "misbehavior in DESCRIBE of ~S" i)))) + + ;;;; success diff --git a/tests/interface.pure.lisp b/tests/interface.pure.lisp index 156c535..2a27b35 100644 --- a/tests/interface.pure.lisp +++ b/tests/interface.pure.lisp @@ -42,49 +42,6 @@ (describe #(1 2 3)) (describe #2a((1 2) (3 4))) -;;; support for DESCRIBE tests -(defstruct to-be-described a b) -(defclass forward-describe-class (forward-describe-ref) (a)) - -;;; DESCRIBE should run without signalling an error. -(describe (make-to-be-described)) -(describe 12) -(describe "a string") -(describe 'symbolism) -(describe (find-package :cl)) -(describe '(a list)) -(describe #(a vector)) - -;;; The DESCRIBE-OBJECT methods for built-in CL stuff should do -;;; FRESH-LINE and TERPRI neatly. -(dolist (i (list (make-to-be-described :a 14) 12 "a string" - #0a0 #(1 2 3) #2a((1 2) (3 4)) 'sym :keyword - (find-package :keyword) (list 1 2 3) - nil (cons 1 2) (make-hash-table) - (let ((h (make-hash-table))) - (setf (gethash 10 h) 100 - (gethash 11 h) 121) - h) - (make-condition 'simple-error) - (make-condition 'simple-error :format-control "fc") - #'car #'make-to-be-described (lambda (x) (+ x 11)) - (constantly 'foo) #'(setf to-be-described-a) - #'describe-object (find-class 'to-be-described) - (find-class 'forward-describe-class) - (find-class 'forward-describe-ref) (find-class 'cons))) - (let ((s (with-output-to-string (s) - (write-char #\x s) - (describe i s)))) - (unless (and (char= #\x (char s 0)) - ;; one leading #\NEWLINE from FRESH-LINE or the like, no more - (char= #\newline (char s 1)) - (char/= #\newline (char s 2)) - ;; one trailing #\NEWLINE from TERPRI or the like, no more - (let ((n (length s))) - (and (char= #\newline (char s (- n 1))) - (char/= #\newline (char s (- n 2)))))) - (error "misbehavior in DESCRIBE of ~S" i)))) - ;;; TYPEP, SUBTYPEP, UPGRADED-ARRAY-ELEMENT-TYPE and ;;; UPGRADED-COMPLEX-PART-TYPE should be able to deal with NIL as an ;;; environment argument diff --git a/tests/mop-11.impure-cload.lisp b/tests/mop-11.impure-cload.lisp new file mode 100644 index 0000000..f3900b0 --- /dev/null +++ b/tests/mop-11.impure-cload.lisp @@ -0,0 +1,45 @@ +;;;; miscellaneous side-effectful tests of the MOP + +;;;; 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. + +;;; this file attempts to test possible metacircularity issues arising +;;; from changing discriminating functions. + +(defpackage "MOP-11" + (:use "CL" "SB-MOP")) +(in-package "MOP-11") + +(defclass gf1-class (standard-generic-function) () + (:metaclass funcallable-standard-class)) +(defgeneric gf1 (x) + (:method ((x t)) x) + (:generic-function-class gf1-class)) +(assert (= (gf1 3) 3)) + +(defclass gf2-class (standard-generic-function) () + (:metaclass funcallable-standard-class)) +(defgeneric gf2 (y) + (:method ((x number)) x) + (:generic-function-class gf2-class)) +(assert (= (gf2 4) 4)) + +(defgeneric gf1a (x) + (:method ((x symbol)) (symbol-name x)) + (:generic-function-class gf1-class)) +(assert (string= (gf1a t) "T")) + +(defclass gf3-class (standard-generic-function) () + (:metaclass funcallable-standard-class)) +(defgeneric gf3 (x y) + (:method ((x number) (y number)) (+ x y)) + (:generic-function-class gf3-class)) +(assert (= (gf3 1 2) 3)) diff --git a/version.lisp-expr b/version.lisp-expr index edfbde1..581a07d 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.8.40" +"0.9.8.41" -- 1.7.10.4