From 6c129930bd75f25a66aa0cbf0e5bc8091401d5ce Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Wed, 14 Aug 2002 13:25:58 +0000 Subject: [PATCH] 0.7.6.21: (I hope this checkin works. I have issued conflicting instructions to do with adding and removal of .cvsignore files, and it's possible that this has confused things. Only the .cvsignore files should be messed up, if anything has gone wrong) Merge APD patch for BUG 191a (sbcl-devel 2002-08-12) ... s/slots-for-this-defclass/slot-names-for-this-defclass/ Merge patch from Gerd Moelmann regarding the long form of DEFINE-METHOD-COMBINATION (cmucl-imp 2002-06-18) Remove now-unneccessary .cvsignore files (having added a "master" cvsignore file in sbcl's CVSROOT) --- .cvsignore | 7 ------ doc/.cvsignore | 1 - src/assembly/alpha/.cvsignore | 4 ---- src/assembly/ppc/.cvsignore | 4 ---- src/assembly/sparc/.cvsignore | 4 ---- src/assembly/x86/.cvsignore | 4 ---- src/code/.cvsignore | 7 ------ src/cold/warm.lisp | 1 + src/pcl/.cvsignore | 37 ------------------------------ src/pcl/defclass.lisp | 16 +++++++++++-- src/pcl/defcombin.lisp | 3 ++- src/pcl/slot-name.lisp | 51 +++++++++++++++++++++++++++++++++++++++++ src/pcl/slots-boot.lisp | 26 --------------------- tests/clos.impure.lisp | 14 +++++++++++ tests/clos.test.sh | 36 +++++++++++++++++++++++++++++ version.lisp-expr | 2 +- 16 files changed, 119 insertions(+), 98 deletions(-) delete mode 100644 .cvsignore delete mode 100644 doc/.cvsignore delete mode 100644 src/assembly/alpha/.cvsignore delete mode 100644 src/assembly/ppc/.cvsignore delete mode 100644 src/assembly/sparc/.cvsignore delete mode 100644 src/assembly/x86/.cvsignore delete mode 100644 src/code/.cvsignore delete mode 100644 src/pcl/.cvsignore create mode 100644 src/pcl/slot-name.lisp diff --git a/.cvsignore b/.cvsignore deleted file mode 100644 index cd87c38..0000000 --- a/.cvsignore +++ /dev/null @@ -1,7 +0,0 @@ -obj -output -ChangeLog -customize-backend-subfeatures.lisp -customize-target-features.lisp -local-target-features.lisp-expr - diff --git a/doc/.cvsignore b/doc/.cvsignore deleted file mode 100644 index 1936cc1..0000000 --- a/doc/.cvsignore +++ /dev/null @@ -1 +0,0 @@ -html diff --git a/src/assembly/alpha/.cvsignore b/src/assembly/alpha/.cvsignore deleted file mode 100644 index 26ab28f..0000000 --- a/src/assembly/alpha/.cvsignore +++ /dev/null @@ -1,4 +0,0 @@ -alloc.fasl -arith.fasl -array.fasl -assem-rtns.fasl diff --git a/src/assembly/ppc/.cvsignore b/src/assembly/ppc/.cvsignore deleted file mode 100644 index 26ab28f..0000000 --- a/src/assembly/ppc/.cvsignore +++ /dev/null @@ -1,4 +0,0 @@ -alloc.fasl -arith.fasl -array.fasl -assem-rtns.fasl diff --git a/src/assembly/sparc/.cvsignore b/src/assembly/sparc/.cvsignore deleted file mode 100644 index 26ab28f..0000000 --- a/src/assembly/sparc/.cvsignore +++ /dev/null @@ -1,4 +0,0 @@ -alloc.fasl -arith.fasl -array.fasl -assem-rtns.fasl diff --git a/src/assembly/x86/.cvsignore b/src/assembly/x86/.cvsignore deleted file mode 100644 index 26ab28f..0000000 --- a/src/assembly/x86/.cvsignore +++ /dev/null @@ -1,4 +0,0 @@ -alloc.fasl -arith.fasl -array.fasl -assem-rtns.fasl diff --git a/src/code/.cvsignore b/src/code/.cvsignore deleted file mode 100644 index f8ef852..0000000 --- a/src/code/.cvsignore +++ /dev/null @@ -1,7 +0,0 @@ -describe.fasl -force-delayed-defbangmethods.fasl -foreign.fasl -inspect.fasl -ntrace.fasl -profile.fasl -run-program.fasl diff --git a/src/cold/warm.lisp b/src/cold/warm.lisp index 2dde8b5..a89de69 100644 --- a/src/cold/warm.lisp +++ b/src/cold/warm.lisp @@ -176,6 +176,7 @@ "src/pcl/macros" "src/pcl/compiler-support" "src/pcl/low" + "src/pcl/slot-name" "src/pcl/defclass" "src/pcl/defs" "src/pcl/fngen" diff --git a/src/pcl/.cvsignore b/src/pcl/.cvsignore deleted file mode 100644 index e513b6a..0000000 --- a/src/pcl/.cvsignore +++ /dev/null @@ -1,37 +0,0 @@ -boot.fasl -braid.fasl -cache.fasl -combin.fasl -compiler-support.fasl -cpl.fasl -ctypes.fasl -defclass.fasl -defcombin.fasl -defs.fasl -describe.fasl -dfun.fasl -dlisp2.fasl -dlisp3.fasl -dlisp.fasl -documentation.fasl -early-low.fasl -env.fasl -fast-init.fasl -fixup.fasl -fngen.fasl -fsc.fasl -generic-functions.fasl -gray-streams-class.fasl -gray-streams.fasl -init.fasl -low.fasl -macros.fasl -methods.fasl -precom1.fasl -precom2.fasl -print-object.fasl -slots-boot.fasl -slots.fasl -std-class.fasl -vector.fasl -walk.fasl diff --git a/src/pcl/defclass.lisp b/src/pcl/defclass.lisp index dfba214..ac41b14 100644 --- a/src/pcl/defclass.lisp +++ b/src/pcl/defclass.lisp @@ -48,6 +48,7 @@ (defvar *initfunctions-for-this-defclass*) (defvar *readers-for-this-defclass*) (defvar *writers-for-this-defclass*) +(defvar *slot-names-for-this-defclass*) ;;; Like the DEFMETHOD macro, the expansion of the DEFCLASS macro is ;;; fixed. DEFCLASS always expands into a call to LOAD-DEFCLASS. Until @@ -81,7 +82,8 @@ (let ((*initfunctions-for-this-defclass* ()) (*readers-for-this-defclass* ()) ;Truly a crock, but we got - (*writers-for-this-defclass* ())) ;to have it to live nicely. + (*writers-for-this-defclass* ()) ;to have it to live nicely. + (*slot-names-for-this-defclass* ())) (let ((canonical-slots (mapcar (lambda (spec) (canonicalize-slot-specification name spec)) @@ -107,6 +109,13 @@ ,@(mapcar (lambda (x) `(declaim (ftype (function (t t) t) ,x))) *writers-for-this-defclass*) + ,@(mapcar (lambda (x) + `(declaim (ftype (function (t) t) + ,(slot-reader-symbol x) + ,(slot-boundp-symbol x)) + (ftype (function (t t) t) + ,(slot-writer-symbol x)))) + *slot-names-for-this-defclass*) (let ,(mapcar #'cdr *initfunctions-for-this-defclass*) (load-defclass ',name ',metaclass @@ -180,10 +189,12 @@ (cond ((and (symbolp spec) (not (keywordp spec)) (not (memq spec '(t nil)))) + (push spec *slot-names-for-this-defclass*) `'(:name ,spec)) ((not (consp spec)) (error "~S is not a legal slot specification." spec)) ((null (cdr spec)) + (push (car spec) *slot-names-for-this-defclass*) `'(:name ,(car spec))) ((null (cddr spec)) (error "In DEFCLASS ~S, the slot specification ~S is obsolete.~%~ @@ -196,6 +207,7 @@ (initargs ()) (unsupplied (list nil)) (initform (getf spec :initform unsupplied))) + (push name *slot-names-for-this-defclass*) (doplist (key val) spec (case key (:accessor (push val readers) @@ -219,7 +231,7 @@ (if (eq initform unsupplied) `(list* ,@spec) `(list* :initfunction ,(make-initfunction initform) ,@spec)))))) - + (defun canonicalize-defclass-option (class-name option) (declare (ignore class-name)) (case (car option) diff --git a/src/pcl/defcombin.lisp b/src/pcl/defcombin.lisp index dacd520..f91b20f 100644 --- a/src/pcl/defcombin.lisp +++ b/src/pcl/defcombin.lisp @@ -208,9 +208,10 @@ (declare (ignore nms cm-args)) (apply (lambda (generic-function type options) - (declare (ignore generic-function options)) + (declare (ignore generic-function)) (make-instance 'long-method-combination :type type + :options options :documentation doc)) args)) :definition-source `((define-method-combination ,type) diff --git a/src/pcl/slot-name.lisp b/src/pcl/slot-name.lisp new file mode 100644 index 0000000..1ad1c73 --- /dev/null +++ b/src/pcl/slot-name.lisp @@ -0,0 +1,51 @@ +;;;; This software is part of the SBCL system. See the README file for +;;;; more information. + +;;;; This software is derived from software originally released by Xerox +;;;; Corporation. Copyright and release statements follow. Later modifications +;;;; to the software are in the public domain and are provided with +;;;; absolutely no warranty. See the COPYING and CREDITS files for more +;;;; information. + +;;;; copyright information from original PCL sources: +;;;; +;;;; Copyright (c) 1985, 1986, 1987, 1988, 1989, 1990 Xerox Corporation. +;;;; All rights reserved. +;;;; +;;;; Use and copying of this software and preparation of derivative works based +;;;; upon this software are permitted. Any distribution of this software or +;;;; derivative works must comply with all applicable United States export +;;;; control laws. +;;;; +;;;; This software is made available AS IS, and Xerox Corporation makes no +;;;; warranty about the software, its performance or its conformity to any +;;;; specification. + +(in-package "SB-PCL") + +(defmacro slot-symbol (slot-name type) + `(if (and (symbolp ,slot-name) (symbol-package ,slot-name)) + (or (get ,slot-name ',(ecase type + (reader 'reader-symbol) + (writer 'writer-symbol) + (boundp 'boundp-symbol))) + (intern (format nil "~A ~A slot ~A" + (package-name (symbol-package ,slot-name)) + (symbol-name ,slot-name) + ,(symbol-name type)) + *slot-accessor-name-package*)) + (progn + (error "Non-symbol and non-interned symbol slot name accessors~ + are not yet implemented.") + ;;(make-symbol (format nil "~A ~A" ,slot-name ,type)) + ))) + +(defun slot-reader-symbol (slot-name) + (slot-symbol slot-name reader)) + +(defun slot-writer-symbol (slot-name) + (slot-symbol slot-name writer)) + +(defun slot-boundp-symbol (slot-name) + (slot-symbol slot-name boundp)) + diff --git a/src/pcl/slots-boot.lisp b/src/pcl/slots-boot.lisp index 9fc23ba..4ee0df1 100644 --- a/src/pcl/slots-boot.lisp +++ b/src/pcl/slots-boot.lisp @@ -23,32 +23,6 @@ (in-package "SB-PCL") -(defmacro slot-symbol (slot-name type) - `(if (and (symbolp ,slot-name) (symbol-package ,slot-name)) - (or (get ,slot-name ',(ecase type - (reader 'reader-symbol) - (writer 'writer-symbol) - (boundp 'boundp-symbol))) - (intern (format nil "~A ~A slot ~A" - (package-name (symbol-package ,slot-name)) - (symbol-name ,slot-name) - ,(symbol-name type)) - *slot-accessor-name-package*)) - (progn - (error "Non-symbol and non-interned symbol slot name accessors~ - are not yet implemented.") - ;;(make-symbol (format nil "~A ~A" ,slot-name ,type)) - ))) - -(defun slot-reader-symbol (slot-name) - (slot-symbol slot-name reader)) - -(defun slot-writer-symbol (slot-name) - (slot-symbol slot-name writer)) - -(defun slot-boundp-symbol (slot-name) - (slot-symbol slot-name boundp)) - (defmacro asv-funcall (sym slot-name type &rest args) (declare (ignore type)) `(if (fboundp ',sym) diff --git a/tests/clos.impure.lisp b/tests/clos.impure.lisp index 1e70590..ab0e2b4 100644 --- a/tests/clos.impure.lisp +++ b/tests/clos.impure.lisp @@ -212,6 +212,20 @@ (assert (eq (ffin *cod*) 'almost-triang-fin)) (assert (equalp #((:before cod) (cod)) *clos-dispatch-side-fx*)) +;;; Until sbcl-0.7.6.21, the long form of DEFINE-METHOD-COMBINATION +;;; ignored its options; Gerd Moellmann found and fixed the problem +;;; for cmucl (cmucl-imp 2002-06-18). +(define-method-combination test-mc (x) + ;; X above being a method-group-specifier + ((primary () :required t)) + `(call-method ,(first primary))) + +(defgeneric gf (obj) + (:method-combination test-mc 1)) + +(defmethod gf (obj) + obj) + ;;;; success (sb-ext:quit :unix-status 104) diff --git a/tests/clos.test.sh b/tests/clos.test.sh index 41d7f88..65dd5d8 100644 --- a/tests/clos.test.sh +++ b/tests/clos.test.sh @@ -45,6 +45,28 @@ EOF fi } +# Test that a file compiles cleanly, with no ERRORs, WARNINGs or +# STYLE-WARNINGs. +# +# Maybe this wants to be in a compiler.test.sh script? This function +# was originally written to test APD's patch for slot readers and +# writers not being known to the compiler. -- CSR, 2002-08-14 +expect_clean_compile () +{ + $SBCL < $tmpfilename < $tmpfilename <