From d8346491af87b66677657e4b934ddeae1e749250 Mon Sep 17 00:00:00 2001 From: Christophe Rhodes Date: Mon, 2 Dec 2002 16:59:08 +0000 Subject: [PATCH] =?utf8?q?0.7.10.8:=20 Staging-post=20on=20the=20way=20to=20?= =?utf8?q?working=20INLINE/MACROLET=20 ...=20implement=20previously=20(MACRO?= =?utf8?q?LET=20((DEF=20...))=20(DEF=20...))=20INLINE=20 functions=20as=20d?= =?utf8?q?efined=20by=20global=20!DEF=20macros=20 ...=20don't=20touch=20SORT?= =?utf8?q?-VECTOR,=20as=20it=20is=20complicated=20 ...=20implement=20a=20BUG?= =?utf8?q?=20117=20bogowarning=20workaround=20in=20 code/defstruct.lisp=20 ?= =?utf8?q?The=20plan=20from=20here=20is=20to=20move=20FIND=20and=20friends=20?= =?utf8?q?into=20the=20realm=20of=20 SOURCE-TRANSFORMS,=20so=20that=20the=20?= =?utf8?q?cross-compiler=20is=20born=20knowing=20how=20to=20 compile=20FIND;?= =?utf8?q?=20a=20similar=20solution=20is=20likely=20for=20SORT-VECTOR.=20=20?= =?utf8?q?Then=20 defensive=20code=20can=20be=20written=20around=20a=20versi?= =?utf8?q?on=20of=20 MAYBE-INLINE-SYNTACTIC-CLOSURE=20(as=20per=20CSR=20sbcl?= =?utf8?q?-devel=202002-07-02=20"BUG=20 156=20and=20INLINE=20FIND"),=20and=20?= =?utf8?q?voil=E0!=20working=20INLINE.?= MIME-Version: 1.0 Content-Type: text/plain; charset=utf8 Content-Transfer-Encoding: 8bit --- src/code/defstruct.lisp | 6 ++- src/code/float.lisp | 107 ++++++++++++++++++++++++----------------------- src/code/seq.lisp | 90 ++++++++++++++++++--------------------- src/code/sort.lisp | 2 +- version.lisp-expr | 2 +- 5 files changed, 101 insertions(+), 106 deletions(-) diff --git a/src/code/defstruct.lisp b/src/code/defstruct.lisp index 2adbc99..eece961 100644 --- a/src/code/defstruct.lisp +++ b/src/code/defstruct.lisp @@ -1523,8 +1523,12 @@ (let ((dsd (find (symbol-name slot-name) dd-slots :key #'dsd-%name :test #'string=))) + ;; KLUDGE: bug 117 bogowarning. Neither + ;; DECLAREing the type nor TRULY-THE cut + ;; the mustard -- it still gives warnings. + (enforce-type dsd defstruct-slot-description) `(setf (,(dsd-accessor-name dsd) ,object-gensym) - ,slot-name))) + ,slot-name))) slot-names) ,object-gensym)) diff --git a/src/code/float.lisp b/src/code/float.lisp index 4f411f2..91bafe6 100644 --- a/src/code/float.lisp +++ b/src/code/float.lisp @@ -196,59 +196,60 @@ (and (zerop (ldb sb!vm:long-float-exponent-byte (long-float-exp-bits x))) (not (zerop x)))))) -(macrolet ((def (name doc single double #!+(and long-float x86) long) - `(defun ,name (x) - ,doc - (number-dispatch ((x float)) - ((single-float) - (let ((bits (single-float-bits x))) - (and (> (ldb sb!vm:single-float-exponent-byte bits) - sb!vm:single-float-normal-exponent-max) - ,single))) - ((double-float) - (let ((hi (double-float-high-bits x)) - (lo (double-float-low-bits x))) - (declare (ignorable lo)) - (and (> (ldb sb!vm:double-float-exponent-byte hi) - sb!vm:double-float-normal-exponent-max) - ,double))) - #!+(and long-float x86) - ((long-float) - (let ((exp (long-float-exp-bits x)) - (hi (long-float-high-bits x)) - (lo (long-float-low-bits x))) - (declare (ignorable lo)) - (and (> (ldb sb!vm:long-float-exponent-byte exp) - sb!vm:long-float-normal-exponent-max) - ,long))))))) - - (def float-infinity-p - "Return true if the float X is an infinity (+ or -)." - (zerop (ldb sb!vm:single-float-significand-byte bits)) - (and (zerop (ldb sb!vm:double-float-significand-byte hi)) - (zerop lo)) - #!+(and long-float x86) - (and (zerop (ldb sb!vm:long-float-significand-byte hi)) - (zerop lo))) - - (def float-nan-p - "Return true if the float X is a NaN (Not a Number)." - (not (zerop (ldb sb!vm:single-float-significand-byte bits))) - (or (not (zerop (ldb sb!vm:double-float-significand-byte hi))) - (not (zerop lo))) - #!+(and long-float x86) - (or (not (zerop (ldb sb!vm:long-float-significand-byte hi))) - (not (zerop lo)))) - - (def float-trapping-nan-p - "Return true if the float X is a trapping NaN (Not a Number)." - (zerop (logand (ldb sb!vm:single-float-significand-byte bits) - sb!vm:single-float-trapping-nan-bit)) - (zerop (logand (ldb sb!vm:double-float-significand-byte hi) - sb!vm:double-float-trapping-nan-bit)) - #!+(and long-float x86) - (zerop (logand (ldb sb!vm:long-float-significand-byte hi) - sb!vm:long-float-trapping-nan-bit)))) +(defmacro !define-float-dispatching-function + (name doc single double #!+(and long-float x86) long) + `(defun ,name (x) + ,doc + (number-dispatch ((x float)) + ((single-float) + (let ((bits (single-float-bits x))) + (and (> (ldb sb!vm:single-float-exponent-byte bits) + sb!vm:single-float-normal-exponent-max) + ,single))) + ((double-float) + (let ((hi (double-float-high-bits x)) + (lo (double-float-low-bits x))) + (declare (ignorable lo)) + (and (> (ldb sb!vm:double-float-exponent-byte hi) + sb!vm:double-float-normal-exponent-max) + ,double))) + #!+(and long-float x86) + ((long-float) + (let ((exp (long-float-exp-bits x)) + (hi (long-float-high-bits x)) + (lo (long-float-low-bits x))) + (declare (ignorable lo)) + (and (> (ldb sb!vm:long-float-exponent-byte exp) + sb!vm:long-float-normal-exponent-max) + ,long)))))) + +(!define-float-dispatching-function float-infinity-p + "Return true if the float X is an infinity (+ or -)." + (zerop (ldb sb!vm:single-float-significand-byte bits)) + (and (zerop (ldb sb!vm:double-float-significand-byte hi)) + (zerop lo)) + #!+(and long-float x86) + (and (zerop (ldb sb!vm:long-float-significand-byte hi)) + (zerop lo))) + +(!define-float-dispatching-function float-nan-p + "Return true if the float X is a NaN (Not a Number)." + (not (zerop (ldb sb!vm:single-float-significand-byte bits))) + (or (not (zerop (ldb sb!vm:double-float-significand-byte hi))) + (not (zerop lo))) + #!+(and long-float x86) + (or (not (zerop (ldb sb!vm:long-float-significand-byte hi))) + (not (zerop lo)))) + +(!define-float-dispatching-function float-trapping-nan-p + "Return true if the float X is a trapping NaN (Not a Number)." + (zerop (logand (ldb sb!vm:single-float-significand-byte bits) + sb!vm:single-float-trapping-nan-bit)) + (zerop (logand (ldb sb!vm:double-float-significand-byte hi) + sb!vm:double-float-trapping-nan-bit)) + #!+(and long-float x86) + (zerop (logand (ldb sb!vm:long-float-significand-byte hi) + sb!vm:long-float-trapping-nan-bit))) ;;; If denormalized, use a subfunction from INTEGER-DECODE-FLOAT to find the ;;; actual exponent (and hence how denormalized it is), otherwise we just diff --git a/src/code/seq.lisp b/src/code/seq.lisp index dc39f2f..aee2434 100644 --- a/src/code/seq.lisp +++ b/src/code/seq.lisp @@ -1964,46 +1964,36 @@ ;;; the user interface to FIND and POSITION: Get all our ducks in a ;;; row, then call %FIND-POSITION. (declaim (inline find position)) -(macrolet ((def-find-position (fun-name values-index) - `(defun ,fun-name (item - sequence - &key - from-end - (start 0) - end - key - test - test-not) - (nth-value - ,values-index - (%find-position item - sequence - from-end - start - end - (effective-find-position-key key) - (effective-find-position-test test - test-not)))))) - (def-find-position find 0) - (def-find-position position 1)) +(defmacro !def-find-position (fun-name values-index) + `(defun ,fun-name (item sequence &key + from-end (start 0) end + key test test-not) + (nth-value + ,values-index + (%find-position item sequence + from-end start + end (effective-find-position-key key) + (effective-find-position-test test test-not))))) +(!def-find-position find 0) +(!def-find-position position 1) ;;; the user interface to FIND-IF and POSITION-IF, entirely analogous ;;; to the interface to FIND and POSITION (declaim (inline find-if position-if)) -(macrolet ((def-find-position-if (fun-name values-index) - `(defun ,fun-name (predicate sequence - &key from-end (start 0) end key) - (nth-value - ,values-index - (%find-position-if (%coerce-callable-to-fun predicate) - sequence - from-end - start - end - (effective-find-position-key key)))))) - - (def-find-position-if find-if 0) - (def-find-position-if position-if 1)) +(defmacro !def-find-position-if (fun-name values-index) + `(defun ,fun-name (predicate sequence + &key from-end (start 0) end key) + (nth-value + ,values-index + (%find-position-if (%coerce-callable-to-fun predicate) + sequence + from-end + start + end + (effective-find-position-key key))))) + +(!def-find-position-if find-if 0) +(!def-find-position-if position-if 1) ;;; the deprecated functions FIND-IF-NOT and POSITION-IF-NOT. We ;;; didn't bother to worry about optimizing them, except note that on @@ -2026,20 +2016,20 @@ ;;; FIXME: Maybe remove uses of these deprecated functions (and ;;; definitely of :TEST-NOT) within the implementation of SBCL. (declaim (inline find-if-not position-if-not)) -(macrolet ((def-find-position-if-not (fun-name values-index) - `(defun ,fun-name (predicate sequence - &key from-end (start 0) end key) - (nth-value - ,values-index - (%find-position-if-not (%coerce-callable-to-fun predicate) - sequence - from-end - start - end - (effective-find-position-key key)))))) - - (def-find-position-if-not find-if-not 0) - (def-find-position-if-not position-if-not 1)) +(defmacro !def-find-position-if-not (fun-name values-index) + `(defun ,fun-name (predicate sequence + &key from-end (start 0) end key) + (nth-value + ,values-index + (%find-position-if-not (%coerce-callable-to-fun predicate) + sequence + from-end + start + end + (effective-find-position-key key))))) + +(!def-find-position-if-not find-if-not 0) +(!def-find-position-if-not position-if-not 1) ;;;; COUNT-IF, COUNT-IF-NOT, and COUNT diff --git a/src/code/sort.lisp b/src/code/sort.lisp index 78c291d..afff387 100644 --- a/src/code/sort.lisp +++ b/src/code/sort.lisp @@ -72,7 +72,7 @@ (rotatef (%elt 1) (%elt current-heap-size)) (decf current-heap-size) (%heapify 1)))))) - + ;; FIXME: Oh dear. (declaim (inline sort-vector)) (defun sort-vector (vector start end predicate key) (declare (type vector vector)) diff --git a/version.lisp-expr b/version.lisp-expr index 2e5748d..7ba229d 100644 --- a/version.lisp-expr +++ b/version.lisp-expr @@ -18,4 +18,4 @@ ;;; versions, especially for internal versions off the main CVS ;;; branch, it gets hairier, e.g. "0.pre7.14.flaky4.13".) -"0.7.10.7" +"0.7.10.8" -- 1.7.10.4