From: William Harold Newman Date: Thu, 10 May 2001 15:18:02 +0000 (+0000) Subject: 0.6.12.7: X-Git-Url: http://repo.macrolet.net/gitweb/?a=commitdiff_plain;h=f2aa2d01b8d69f1c7bff18f86279d4f1018fe127;p=sbcl.git 0.6.12.7: Make sure that we "mkdir output/" before we use it in the build process. (MNA pointed out that we used it before we made it.) Use "uname -m" to figure out sbcl_arch default. merged MNA PCL fixes from sbcl-devel 2001-05-09 (including port of Pierre Mai's method combination fixes from cmucl-imp 2001-04-26) added regression test for method combination fix Bug 14 was mostly fixed already: the problem with INVALID-METHOD-ERROR complaining about being outside a method combination function went away some time ago. The MNA/Mai patch above improves method combination error reporting further, so it's definitely time to retire 14 from BUGS. --- diff --git a/BUGS b/BUGS index a839434..ce864fd 100644 --- a/BUGS +++ b/BUGS @@ -118,33 +118,6 @@ WORKAROUND: (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 diff --git a/make-config.sh b/make-config.sh index c157609..6a6c860 100644 --- a/make-config.sh +++ b/make-config.sh @@ -18,6 +18,9 @@ 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 @@ -25,9 +28,24 @@ echo ';;;; Please do not edit it by hand.' > $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 @@ -52,25 +70,33 @@ echo //setting up OS-dependent information 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 diff --git a/src/code/late-target-error.lisp b/src/code/late-target-error.lisp index af708fe..abd375f 100644 --- a/src/code/late-target-error.lisp +++ b/src/code/late-target-error.lisp @@ -77,19 +77,6 @@ ;; 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 diff --git a/src/pcl/braid.lisp b/src/pcl/braid.lisp index 208db50..307e520 100644 --- a/src/pcl/braid.lisp +++ b/src/pcl/braid.lisp @@ -118,11 +118,6 @@ 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 diff --git a/src/pcl/combin.lisp b/src/pcl/combin.lisp index 1c600ff..2ca53cc 100644 --- a/src/pcl/combin.lisp +++ b/src/pcl/combin.lisp @@ -306,15 +306,30 @@ (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) diff --git a/src/pcl/defs.lisp b/src/pcl/defs.lisp index 334206d..7cc68d3 100644 --- a/src/pcl/defs.lisp +++ b/src/pcl/defs.lisp @@ -191,21 +191,13 @@ (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)))) @@ -213,19 +205,9 @@ (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) @@ -246,24 +228,6 @@ (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) @@ -276,21 +240,13 @@ (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) @@ -298,15 +254,16 @@ (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) @@ -315,9 +272,6 @@ (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 diff --git a/tests/clos.test.sh b/tests/clos.test.sh new file mode 100644 index 0000000..407088e --- /dev/null +++ b/tests/clos.test.sh @@ -0,0 +1,88 @@ +#!/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 < $tmpfilename < $tmpfilename < $tmpfilename <$testfilename <