Permalink
Browse files

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.
  • Loading branch information...
1 parent 672ac58 commit f2aa2d01b8d69f1c7bff18f86279d4f1018fe127 William Harold Newman committed May 10, 2001
Showing with 187 additions and 138 deletions.
  1. +0 −27 BUGS
  2. +46 −20 make-config.sh
  3. +0 −13 src/code/late-target-error.lisp
  4. +0 −5 src/pcl/braid.lisp
  5. +24 −9 src/pcl/combin.lisp
  6. +15 −61 src/pcl/defs.lisp
  7. +88 −0 tests/clos.test.sh
  8. +1 −1 tests/run-tests.sh
  9. +12 −1 tests/side-effectful-pathnames.test.sh
  10. +1 −1 version.lisp-expr
View
27 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
View
@@ -18,16 +18,34 @@
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 ';;;; 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
@@ -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
View
@@ -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
View
@@ -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)
View
@@ -191,41 +191,23 @@
(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)
@@ -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,37 +240,30 @@
(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)
(if (eq *boot-state* 'early)
(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
Oops, something went wrong.

0 comments on commit f2aa2d0

Please sign in to comment.