+++ /dev/null
-obj
-output
-ChangeLog
-customize-backend-subfeatures.lisp
-customize-target-features.lisp
-local-target-features.lisp-expr
-
+++ /dev/null
-alloc.fasl
-arith.fasl
-array.fasl
-assem-rtns.fasl
+++ /dev/null
-alloc.fasl
-arith.fasl
-array.fasl
-assem-rtns.fasl
+++ /dev/null
-alloc.fasl
-arith.fasl
-array.fasl
-assem-rtns.fasl
+++ /dev/null
-alloc.fasl
-arith.fasl
-array.fasl
-assem-rtns.fasl
+++ /dev/null
-describe.fasl
-force-delayed-defbangmethods.fasl
-foreign.fasl
-inspect.fasl
-ntrace.fasl
-profile.fasl
-run-program.fasl
"src/pcl/macros"
"src/pcl/compiler-support"
"src/pcl/low"
+ "src/pcl/slot-name"
"src/pcl/defclass"
"src/pcl/defs"
"src/pcl/fngen"
+++ /dev/null
-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
(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
(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))
,@(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
(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.~%~
(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)
(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)
(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)
--- /dev/null
+;;;; 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")
+\f
+(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))
+
(in-package "SB-PCL")
\f
-(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)
(assert (eq (ffin *cod*) 'almost-triang-fin))
(assert (equalp #((:before cod) (cod)) *clos-dispatch-side-fx*))
\f
+;;; 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)
+\f
;;;; success
(sb-ext:quit :unix-status 104)
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 <<EOF
+ (multiple-value-bind (pathname warnings-p failure-p)
+ (compile-file "$1")
+ (declare (ignore pathname))
+ (assert (not warnings-p))
+ (assert (not failure-p))
+ (sb-ext:quit :unix-status 52))
+EOF
+ if [ $? != 52 ]; then
+ echo clean-compile $1 test failed: $?
+ exit 1
+ fi
+}
+
base_tmpfilename="clos-test-$$-tmp"
tmpfilename="$base_tmpfilename.lisp"
compiled_tmpfilename="$base_tmpfilename.fasl"
EOF
expect_load_error $tmpfilename
+# Until sbcl-0.7.6.21, PCL signalled spurious STYLE-WARNINGs on
+# compilation of this form; the report (bug #191a.) and a patch
+# suppressing these were provided by Alexey Dejenka in quick
+# succession.
+cat > $tmpfilename <<EOF
+ (in-package :cl-user)
+ (defclass another-class-with-slots ()
+ (a-new-slot-name))
+ (defun foo (x)
+ (values (setf (slot-value x 'a-new-slot-name) 2)
+ (slot-value x 'a-new-slot-name)))
+EOF
+expect_clean_compile $tmpfilename
+
rm $tmpfilename
rm $compiled_tmpfilename
;;; for internal versions, especially for internal versions off the
;;; main CVS branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".)
-"0.7.6.20"
+"0.7.6.21"
projects / sbcl.git / commitdiff