(during macroexpansion of IN-PACKAGE,
during macroexpansion of DEFFOO)
-14:
- The ANSI syntax for non-STANDARD method combination types in CLOS is
- (DEFGENERIC FOO (X) (:METHOD-COMBINATION PROGN))
- (DEFMETHOD FOO PROGN ((X BAR)) (PRINT 'NUMBER))
- If you mess this up, omitting the PROGN qualifier in in DEFMETHOD,
- (DEFGENERIC FOO (X) (:METHOD-COMBINATION PROGN))
- (DEFMETHOD FOO ((X BAR)) (PRINT 'NUMBER))
- the error mesage is not easy to understand:
- INVALID-METHOD-ERROR was called outside the dynamic scope
- of a method combination function (inside the body of
- DEFINE-METHOD-COMBINATION or a method on the generic
- function COMPUTE-EFFECTIVE-METHOD).
- It would be better if it were more informative, a la
- The method combination type for this method (STANDARD) does
- not match the method combination type for the generic function
- (PROGN).
- Also, after you make the mistake of omitting the PROGN qualifier
- on a DEFMETHOD, doing a new DEFMETHOD with the correct qualifier
- no longer works:
- (DEFMETHOD FOO PROGN ((X BAR)) (PRINT 'NUMBER))
- gives
- INVALID-METHOD-ERROR was called outside the dynamic scope
- of a method combination function (inside the body of
- DEFINE-METHOD-COMBINATION or a method on the generic
- function COMPUTE-EFFECTIVE-METHOD).
- This is not very helpful..
-
15:
(SUBTYPEP '(FUNCTION (T BOOLEAN) NIL)
'(FUNCTION (FIXNUM FIXNUM) NIL)) => T, T
echo //entering make-config.sh
+echo //ensuring the existence of output/ directory
+if [ ! -d output ] ; then mkdir output; fi
+
ltf=`pwd`/local-target-features.lisp-expr
echo //initializing $ltf
echo ';;;; This is a machine-generated file.' > $ltf
echo ';;;; See make-config.sh.' > $ltf
echo -n '(' >> $ltf
+echo //guessing default target CPU architecture from host architecture
+case `uname -m` in
+ *86) guessed_sbcl_arch=x86 ;;
+ [Aa]lpha) guessed_sbcl_arch=alpha ;;
+ *)
+ # If we're not building on a supported target architecture, we
+ # we have no guess, but it's not an error yet, since maybe
+ # target architecture will be specified explicitly below.
+ guessed_sbcl_arch=''
+ ;;
+esac
+
echo //setting up CPU-architecture-dependent information
-# Currently supported: x86 alpha
-sbcl_arch=${SBCL_ARCH:-x86}
+sbcl_arch=${SBCL_ARCH:-$guessed_sbcl_arch}
+if [ "$sbcl_arch" = "" ] ; then
+ echo "can't guess target SBCL architecture, need SBCL_ARCH environment var"
+ exit 1
+fi
echo -n ":$sbcl_arch" >> $ltf
for d in src/compiler src/assembly; do
echo //setting up symlink $d/target
original_dir=`pwd`
cd src/runtime/
rm -f Config
-if [ `uname` = Linux ]; then
- echo -n ' :linux' >> $ltf
- ln -s Config.$sbcl_arch-linux Config
-elif uname | grep BSD; then
- echo -n ' :bsd' >> $ltf
- if [ `uname` = FreeBSD ]; then
- echo -n ' :freebsd' >> $ltf
- ln -s Config.$sbcl_arch-freebsd Config
- elif [ `uname` = OpenBSD ]; then
- echo -n ' :openbsd' >> $ltf
- ln -s Config.$sbcl_arch-openbsd Config
- else
- echo unsupported BSD variant: `uname`
+case `uname` in
+ Linux)
+ echo -n ' :linux' >> $ltf
+ ln -s Config.$sbcl_arch-linux Config
+ ;;
+ *BSD)
+ echo -n ' :bsd' >> $ltf
+ case `uname` in
+ FreeBSD)
+ echo -n ' :freebsd' >> $ltf
+ ln -s Config.$sbcl_arch-freebsd Config
+ ;;
+ OpenBSD)
+ echo -n ' :openbsd' >> $ltf
+ ln -s Config.$sbcl_arch-openbsd Config
+ ;;
+ *)
+ echo unsupported BSD variant: `uname`
+ exit 1
+ ;;
+ esac
+ ;;
+ *)
+ echo unsupported OS type: `uname`
exit 1
- fi
-else
- echo unsupported OS type: `uname`
- exit 1
-fi
+ ;;
+esac
cd $original_dir
echo //finishing $ltf
;; If ALLOCATION is :CLASS, this is a cons whose car holds the value.
(cell nil :type (or cons null)))
-(eval-when (#-sb-xc :compile-toplevel :load-toplevel :execute)
- ;; the appropriate initialization value for the CPL slot of a
- ;; CONDITION, calculated by looking at the INHERITS information in
- ;; the LAYOUT of the CONDITION
- (defun condition-class-cpl-from-layout (condition)
- (declare (type condition condition))
- (let* ((class (sb!xc:find-class condition))
- (layout (class-layout class))
- (superset (map 'list #'identity (layout-inherits layout))))
- (delete-if (lambda (superclass)
- (not (typep superclass 'condition-class)))
- superset))))
-
;;; KLUDGE: It's not clear to me why CONDITION-CLASS has itself listed
;;; in its CPL, while other classes derived from CONDITION-CLASS don't
;;; have themselves listed in their CPLs. This behavior is inherited
classes)))
(defun !bootstrap-meta-braid ()
- (let* ((name 'class)
- (predicate-name (make-type-predicate-name name)))
- (setf (gdefinition predicate-name)
- #'(lambda (x) (declare (ignore x)) t))
- (do-satisfies-deftype name predicate-name))
(let* ((*create-classes-from-internal-structure-definitions-p* nil)
std-class-wrapper std-class
standard-class-wrapper standard-class
(primary ())
(after ())
(around ()))
- (dolist (m applicable-methods)
- (let ((qualifiers (if (listp m)
- (early-method-qualifiers m)
- (method-qualifiers m))))
- (cond ((member ':before qualifiers) (push m before))
- ((member ':after qualifiers) (push m after))
- ((member ':around qualifiers) (push m around))
- (t
- (push m primary)))))
+ (flet ((lose (method why)
+ (invalid-method-error
+ method
+ "The method ~S ~A.~%~
+ Standard method combination requires all methods to have one~%~
+ of the single qualifiers :AROUND, :BEFORE and :AFTER or to~%~
+ have no qualifier at all."
+ method why)))
+ (dolist (m applicable-methods)
+ (let ((qualifiers (if (listp m)
+ (early-method-qualifiers m)
+ (method-qualifiers m))))
+ (cond
+ ((null qualifiers) (push m primary))
+ ((cdr qualifiers)
+ (lose m "has more than one qualifier"))
+ ((eq (car qualifiers) :around)
+ (push m around))
+ ((eq (car qualifiers) :before)
+ (push m before))
+ ((eq (car qualifiers) :after)
+ (push m after))
+ (t
+ (lose m "has an illegal qualifier"))))))
(setq before (reverse before)
after (reverse after)
primary (reverse primary)
(defun inform-type-system-about-std-class (name)
(let ((predicate-name (make-type-predicate-name name)))
(setf (gdefinition predicate-name)
- (make-type-predicate name))
- (do-satisfies-deftype name predicate-name)))
+ (make-type-predicate name))))
(defun make-type-predicate (name)
(let ((cell (find-class-cell name)))
#'(lambda (x)
(funcall (the function (find-class-cell-predicate cell)) x))))
-;This stuff isn't right. Good thing it isn't used.
-;The satisfies predicate has to be a symbol. There is no way to
-;construct such a symbol from a class object if class names change.
-(defun class-predicate (class)
- (when (symbolp class) (setq class (find-class class)))
- #'(lambda (object) (memq class (class-precedence-list (class-of object)))))
-
(defun make-class-eq-predicate (class)
(when (symbolp class) (setq class (find-class class)))
#'(lambda (object) (eq class (class-of object))))
(defun make-eql-predicate (eql-object)
#'(lambda (object) (eql eql-object object)))
-#|| ; The argument to satisfies must be a symbol.
-(deftype class (&optional class)
- (if class
- `(satisfies ,(class-predicate class))
- `(satisfies ,(class-predicate 'class))))
-
-(deftype class-eq (class)
- `(satisfies ,(make-class-eq-predicate class)))
-||#
-
-;;; internal to this file
+;;; internal to this file..
;;;
-;;; These functions are a pale imitiation of their namesake. They accept
+;;; These functions are a pale imitation of their namesake. They accept
;;; class objects or types where they should.
(defun *normalize-type (type)
(cond ((consp type)
(t
(error "~S is not a type." type))))
-;;; Not used...
-#+nil
-(defun unparse-type-list (tlist)
- (mapcar #'unparse-type tlist))
-
-;;; Not used...
-#+nil
-(defun unparse-type (type)
- (if (atom type)
- (if (specializerp type)
- (unparse-type (specializer-type type))
- type)
- (case (car type)
- (eql type)
- (class-eq `(class-eq ,(class-name (cadr type))))
- (class (class-name (cadr type)))
- (t `(,(car type) ,@(unparse-type-list (cdr type)))))))
-
;;; internal to this file...
(defun convert-to-system-type (type)
(case (car type)
(car type)
type))))
-;;; not used...
-#+nil
-(defun *typep (object type)
- (setq type (*normalize-type type))
- (cond ((member (car type) '(eql wrapper-eq class-eq class))
- (specializer-applicable-using-type-p type `(eql ,object)))
- ((eq (car type) 'not)
- (not (*typep object (cadr type))))
- (t
- (typep object (convert-to-system-type type)))))
-
-;;; Writing the missing NOT and AND clauses will improve
-;;; the quality of code generated by generate-discrimination-net, but
-;;; calling subtypep in place of just returning (values nil nil) can be
-;;; very slow. *SUBTYPEP is used by PCL itself, and must be fast.
+;;; Writing the missing NOT and AND clauses will improve the quality
+;;; of code generated by GENERATE-DISCRIMINATION-NET, but calling
+;;; SUBTYPEP in place of just returning (VALUES NIL NIL) can be very
+;;; slow. *SUBTYPEP is used by PCL itself, and must be fast.
+;;;
+;;; FIXME: SB-KERNEL has fast-and-not-quite-precise type code for use
+;;; in the compiler. Could we share some of it here?
(defun *subtypep (type1 type2)
(if (equal type1 type2)
(values t t)
(values (eq type1 type2) t)
(let ((*in-precompute-effective-methods-p* t))
(declare (special *in-precompute-effective-methods-p*))
- ;; *in-precompute-effective-methods-p* is not a good name.
- ;; It changes the way class-applicable-using-class-p works.
+ ;; FIXME: *IN-PRECOMPUTE-EFFECTIVE-METHODS-P* is not a
+ ;; good name. It changes the way
+ ;; CLASS-APPLICABLE-USING-CLASS-P works.
(setq type1 (*normalize-type type1))
(setq type2 (*normalize-type type2))
(case (car type2)
(not
- (values nil nil)) ; Should improve this.
+ (values nil nil)) ; XXX We should improve this.
(and
- (values nil nil)) ; Should improve this.
+ (values nil nil)) ; XXX We should improve this.
((eql wrapper-eq class-eq class)
(multiple-value-bind (app-p maybe-app-p)
(specializer-applicable-using-type-p type2 type1)
(subtypep (convert-to-system-type type1)
(convert-to-system-type type2))))))))
-(defun do-satisfies-deftype (name predicate)
- (declare (ignore name predicate)))
-
(defun make-type-predicate-name (name &optional kind)
(if (symbol-package name)
(intern (format nil
--- /dev/null
+#!/bin/sh
+
+# 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.
+
+# Check that compiling and loading the file $1 generates an error
+# at load time; also that just loading it directly (into the
+# interpreter) generates an error.
+expect_load_error ()
+{
+ # Test compiling and loading.
+ $SBCL <<EOF
+ (compile-file "$1")
+ ;;; But loading the file should fail.
+ (multiple-value-bind (value0 value1) (ignore-errors (load *))
+ (assert (null value0))
+ (format t "VALUE1=~S (~A)~%" value1 value1)
+ (assert (typep value1 'error)))
+ (sb-ext:quit :unix-status 52)
+EOF
+ if [ $? != 52 ]; then
+ echo compile-and-load $1 test failed: $?
+ exit 1
+ fi
+
+ # Test loading into the interpreter.
+ $SBCL <<EOF
+ (multiple-value-bind (value0 value1) (ignore-errors (load "$1"))
+ (assert (null value0))
+ (format t "VALUE1=~S (~A)~%" value1 value1)
+ (assert (typep value1 'error)))
+ (sb-ext:quit :unix-status 52)
+EOF
+ if [ $? != 52 ]; then
+ echo load-into-interpreter $1 test failed: $?
+ exit 1
+ fi
+}
+
+tmpfilename="clos-test-$$-tmp.lisp"
+
+# This should fail, but didn't until sbcl-0.6.12.7, with Martin
+# Atzmueller's port of Pierre Mai's fixes.
+cat > $tmpfilename <<EOF
+ (in-package :cl-user)
+ ;; This definition has too many qualifiers, so loading the
+ ;; DEFMETHOD should fail.
+ (defmethod zut progn :around ((x integer)) (print "integer"))
+EOF
+expect_load_error $tmpfilename
+
+# Even before sbcl-0.6.12.7, this would fail as it should. Let's
+# make sure that it still does.
+cat > $tmpfilename <<EOF
+ (in-package :cl-user)
+ (defgeneric zut (x) (:method-combination progn))
+ ;; This definition is missing the PROGN qualifier, and so the
+ ;; DEFMETHOD should fail.
+ (defmethod zut ((x integer)) (print "integer"))
+EOF
+expect_load_error $tmpfilename
+
+# Even before sbcl-0.6.12.7, this would fail as it should, but Martin
+# Atzmueller's port of Pierre Mai's fixes caused it to generate more
+# correct text in the error message. We can't check that in a regression
+# test until AI gets a mite stronger, but at least we can check that
+# the problem is still detected.
+cat > $tmpfilename <<EOF
+ (in-package :cl-user)
+ (defgeneric zut (x) (:method-combination progn))
+ ;; This definition has too many qualifiers, so loading the
+ ;; DEFMETHOD should fail.
+ (defmethod zut progn :around ((x integer)) (print "integer"))
+EOF
+expect_load_error $tmpfilename
+
+rm $tmpfilename
+
+# success
+exit 104
# absolutely no warranty. See the COPYING and CREDITS files for
# more information.
-# how we invoke SBCL
+# how we invoke SBCL in the tests
export SBCL="${1:-../src/runtime/sbcl --core ../output/sbcl.core --noinform --sysinit /dev/null --userinit /dev/null --noprint --noprogrammer}"
# "Ten four" is the closest numerical slang I can find to "OK", so
#!/bin/sh
+# 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.
+
# LOADing and COMPILEing files with logical pathnames
testdir=`pwd`"/side-effectful-pathnames-test-$$"
testfilestem="load-test"
(in-package :cl-user)
(defparameter *loaded* :yes)
EOF
-${SBCL:-sbcl} <<EOF
+$SBCL <<EOF
(in-package :cl-user)
(setf (logical-pathname-translations "TEST")
(list (list "**;*.*.*" "$testdir/**/*.*")))
;;; versions, and a string like "0.6.5.12" is used for versions which
;;; aren't released but correspond only to CVS tags or snapshots.
-"0.6.12.6"
+"0.6.12.7"
projects / sbcl.git / commitdiff