From 1aee76da48edafa210f60e852913041a843428b7 Mon Sep 17 00:00:00 2001 From: Gabor Melis Date: Mon, 19 Sep 2005 14:18:13 +0000 Subject: [PATCH] 0.9.3.76: * WITH-TIMEOUT doesn't signal a timeout if the timeout is zero for backward compatibility reasons (i.e. not to break CLX). When unsafe unwinds are dealt with this may be revisited. * suggestions from whitespace-o'matic --- src/code/timer.lisp | 16 ++++++++++------ tests/mop-6.impure-cload.lisp | 6 +++--- version.lisp-expr | 2 +- 3 files changed, 14 insertions(+), 10 deletions(-) diff --git a/src/code/timer.lisp b/src/code/timer.lisp index 9ee6089..7f49302 100644 --- a/src/code/timer.lisp +++ b/src/code/timer.lisp @@ -360,9 +360,13 @@ triggers." "Execute the body, asynchronously interrupting it and signalling a TIMEOUT condition after at least EXPIRES seconds have passed." (with-unique-names (timer) - `(let ((,timer (make-timer (lambda () - (cerror "Continue" 'sb!ext::timeout))))) - (schedule-timer ,timer ,expires) - (unwind-protect - (progn ,@body) - (unschedule-timer ,timer))))) + ;; FIXME: a temporary compatibility workaround for CLX, if unsafe + ;; unwinds are handled revisit it. + `(if (> ,expires 0) + (let ((,timer (make-timer (lambda () + (cerror "Continue" 'sb!ext::timeout))))) + (schedule-timer ,timer ,expires) + (unwind-protect + (progn ,@body) + (unschedule-timer ,timer))) + (progn ,@body)))) diff --git a/tests/mop-6.impure-cload.lisp b/tests/mop-6.impure-cload.lisp index 06254d8..55db975 100644 --- a/tests/mop-6.impure-cload.lisp +++ b/tests/mop-6.impure-cload.lisp @@ -19,7 +19,7 @@ (in-package "MOP-6") ;;; COMPUTE-SLOTS :AROUND respecting requested order -(defclass slot-rearrangement-class (standard-class) +(defclass slot-rearrangement-class (standard-class) ()) (defmethod compute-slots ((c slot-rearrangement-class)) (reverse (call-next-method))) @@ -34,7 +34,7 @@ (with-test (:name (compute-slots standard-class :order)) (let ((class (find-class 'rearranged-class))) (finalize-inheritance class) - (assert (equal (mapcar #'slot-definition-name (class-slots class)) + (assert (equal (mapcar #'slot-definition-name (class-slots class)) '(b a))))) (with-test (:name (compute-slots standard-class :slots)) (let ((r (make-instance 'rearranged-class)) @@ -59,7 +59,7 @@ (with-test (:name (compute-slots funcallable-standard-class :order)) (let ((class (find-class 'funcallable-rearranged-class))) (finalize-inheritance class) - (assert (equal (mapcar #'slot-definition-name (class-slots class)) + (assert (equal (mapcar #'slot-definition-name (class-slots class)) '(b a))))) (with-test (:name (compute-slots funcallable-standard-class :slots)) (let ((r (make-instance 'funcallable-rearranged-class)) diff --git a/version.lisp-expr b/version.lisp-expr index d347e12..3946e05 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -17,4 +17,4 @@ ;;; checkins which aren't released. (And occasionally for internal ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.9.4.75" +"0.9.4.76" -- 1.7.10.4