* 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
(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)
(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)
(let ((x 1)) (defun disassemble-closure (y) (if y (setq x y) x)))
(disassemble 'disassemble-closure)
\f
+;;; 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))))
+
+\f
;;;; success
(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
--- /dev/null
+;;;; 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))
;;; 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"
projects / sbcl.git / commitdiff