diff --git a/bin/build-utils.sh b/bin/build-utils.sh index e59fd19236a748594a1de75655b3b9e9253ff4b0..18d6f60e27a1c2cd1ef45f4fed73d556721cda2b 100755 --- a/bin/build-utils.sh +++ b/bin/build-utils.sh @@ -36,6 +36,7 @@ $TARGET/lisp/lisp \ (setq *gc-verbose* nil *interactive* nil) (load "target:tools/clxcom") (load "target:clx/clx-library") +#-ppc (load "target:tools/clmcom") (load "target:tools/hemcom") @@ -61,4 +62,17 @@ fi export MAKE -${MAKE} -C $TARGET/motif/server clean && ${MAKE} -C $TARGET/motif/server +# Don't bother building motifd on ppc; we'll probably never support that again. + +SKIPMOTIF=no +case `uname -s` in + Darwin) + case `uname -p` in + powerpc) SKIPMOTIF=yes ;; + esac ;; +esac + +if [ "$SKIPMOTIF" = "no" ]; then + ${MAKE} -C $TARGET/motif/server clean && ${MAKE} -C $TARGET/motif/server +fi + diff --git a/bin/build.sh b/bin/build.sh index 3b525567be77e591948881b1e50644a2d7592ece..7d6e00c1fa3a049a40b000b75cde6b1e9d3f8c28 100755 --- a/bin/build.sh +++ b/bin/build.sh @@ -39,7 +39,7 @@ ENABLE2="yes" ENABLE3="yes" ENABLE4="yes" -version=20e +version=20f SRCDIR=src BINDIR=bin TOOLDIR=$BINDIR diff --git a/src/code/exports.lisp b/src/code/exports.lisp index 4bd21409cf7b4d272a8bc254076cad3c463af2b4..48cdf00e90a4cf7006f6b26b9857ffca7f181d2c 100644 --- a/src/code/exports.lisp +++ b/src/code/exports.lisp @@ -1072,6 +1072,8 @@ (:export "SIGCONTEXT-LR" "COMPATIBLE-FUNCTION-TYPES-P" "FLOAT-INVALID-OP-1-BYTE" + "FLOAT-INVALID-OP-2-BYTE" + "FLOAT-EXCEPTIONS-SUMMARY-BYTE" "GET-FP-OPERANDS" "FUSED-MULTIPLY-ADD" "FUSED-MULTIPLY-SUBTRACT") @@ -2003,7 +2005,7 @@ "%CALLER-FRAME-AND-PC" "%CHECK-BOUND" "%CLOSURE-FUNCTION" "%CLOSURE-INDEX-REF" "%COS" "%COSH" "%DEPOSIT-FIELD" "%DOUBLE-FLOAT" "%DPB" "%EXP" "%EXPM1" "%HYPOT" "%LDB" - "%LOG" "%LOGB" "%LOG10" "%LOG1P" "%LONG-FLOAT" + "%LOG" "%LOGB" "%LOG10" "%LOG1P" "%LOG2" "%LONG-FLOAT" "%MAKE-COMPLEX" "%MAKE-FUNCALLABLE-INSTANCE" "%MAKE-RATIO" "%MASK-FIELD" "%NEGATE" "%POW" "%RAW-BITS" "%RAW-REF-COMPLEX-DOUBLE" "%RAW-REF-COMPLEX-LONG" diff --git a/src/code/float-trap.lisp b/src/code/float-trap.lisp index a736e0d40c3b1db93e7949d95db615426bd5f294..d67a4fffe62b09ec78536af49cf67decc4a9b2bd 100644 --- a/src/code/float-trap.lisp +++ b/src/code/float-trap.lisp @@ -193,7 +193,8 @@ #+(and darwin ppc) (when (member :invalid current-exceptions) ;; Clear out the bits for the detected invalid operation - (setf (ldb vm:float-invalid-op-1-byte modes) 0))) + (setf (ldb vm:float-invalid-op-1-byte modes) 0) + (setf (ldb vm:float-invalid-op-2-byte modes) 0))) (when accrued-x-p (setf (ldb float-sticky-bits modes) @@ -201,12 +202,18 @@ #+(and darwin ppc) (when (member :invalid current-exceptions) ;; Clear out the bits for the detected invalid operation - (setf (ldb vm:float-invalid-op-1-byte modes) 0))) + (setf (ldb vm:float-invalid-op-1-byte modes) 0) + (setf (ldb vm:float-invalid-op-2-byte modes) 0))) + + #+(and darwin ppc) + (when (or accrued-x-p current-x-p) + (setf (ldb vm:float-exceptions-summary-byte modes) 0)) (when fast-mode-p (if fast-mode (setq modes (logior float-fast-bit modes)) (setq modes (logand (lognot float-fast-bit) modes)))) + (setf (floating-point-modes) modes)) (values)) @@ -261,7 +268,12 @@ (traps (logand (ldb float-exceptions-byte modes) (ldb float-traps-byte modes)))) #+(and darwin ppc) - (let ((new-modes modes)) + (let* ((new-modes modes) + (new-exceptions (logandc2 (ldb float-exceptions-byte new-modes) + traps))) + ;; (format t "sigfpe: modes = #B~32,'0b~%" modes) + ;; (format t "sigfpe: new-exc = #B~32,'0b~%" new-exceptions) + (setf (ldb float-exceptions-byte new-modes) new-exceptions) ;; Clear out all exceptions and save them to the context. ;; ;; XXX: Should we just clear out the bits for the traps that are @@ -273,6 +285,9 @@ ;; XXX: Should we only do that if the invalid trap is enabled? (setf (ldb float-invalid-op-1-byte new-modes) 0) (setf (ldb float-invalid-op-2-byte new-modes) 0) + ;; Clear the FP exception summary bit too. + (setf (ldb float-exceptions-summary-byte new-modes) 0) + ;; (format t "sigfpe: new modes = #B~32,'0b~%" new-modes) (setf (floating-point-modes) new-modes) (setf (sigcontext-floating-point-modes (alien:sap-alien scp (* unix:sigcontext))) @@ -371,7 +386,10 @@ ;; an exception. #+ppc (invalid-mask (if (member :invalid traps) - (dpb 0 vm:float-invalid-op-1-byte #xffffffff) + (dpb 0 + (byte 1 31) + (dpb 0 vm::float-invalid-op-2-byte + (dpb 0 vm:float-invalid-op-1-byte #xffffffff))) #xffffffff)) (orig-modes (gensym))) `(let ((,orig-modes (floating-point-modes))) @@ -387,4 +405,4 @@ ,(logand trap-mask exception-mask) #+ppc ,invalid-mask - #+mips ,(dpb 0 float-exceptions-byte #xffffffff)))))))) + #+mips ,(dpb 0 float-exceptions-byte #xffffffff)))))))) diff --git a/src/code/irrat-dd.lisp b/src/code/irrat-dd.lisp index 438339fa849b7cc97733818a7ad77964fc6d2b77..36051fcac88ac9809d81f491592eb1b531a6aaad 100644 --- a/src/code/irrat-dd.lisp +++ b/src/code/irrat-dd.lisp @@ -44,6 +44,20 @@ 4.4269504088896340735992468100189213742664595w-1 _N"log2(e)-1") +;; l102a+log102b = log10(2) to extra precision +(defconstant l102a + 0.3125w0) + +(defconstant l102b + -1.14700043360188047862611052755069732318101185w-2) + +;; l10ea + l10eb = log10(2) to extra precsion +(defconstant l10ea + 0.5w0) + +(defconstant l10eb + -6.570551809674817234887108108339491770560299w-2) + (defconstant dd-pi 3.141592653589793238462643383279502884197169w0 _N"Pi") @@ -1241,9 +1255,22 @@ pi/4 11001001000011111101101010100010001000010110100011000 010001101001100010 (values (- (dd-%%cos reduced)) (dd-%%sin reduced)))))))) -;;; dd-%log2 -;;; Base 2 logarithm. - +;;; dd-%log2 and dd-%log10 +;;; Base 2 and base 10 logarithm. +;;; +;;; The argument is separated into its exponent and fractional +;;; parts. If the exponent is between -1 and +1, the (natural) +;;; logarithm of the fraction is approximated by +;;; +;;; log(1+x) = x - 0.5 x**2 + x**3 P(x)/Q(x). +;;; +;;; Otherwise, setting z = 2(x-1)/x+1), +;;; +;;; log(x) = z + z**3 R(z)/S(z). +;;; +;;; This gives the natural log. To get the base 2 and base 10 log, +;;; carefully multiply the natural log by log2(e) or log10(e) as +;;; appropriate. (let ((P (make-array 13 :element-type 'double-double-float :initial-contents '( @@ -1304,52 +1331,88 @@ pi/4 11001001000011111101101010100010001000010110100011000 010001101001100010 -1.332535117259762928288745111081235577029w6 1.701761051846631278975701529965589676574w6 )))) + (flet + ((compute-log (x) + ;; Common routine to extract the exponent and fraction from x + ;; and compute the log(f). Return the exponent, the fraction, + ;; and the parts of the polynomial computation that is needed + ;; to finish off the final logarithm. + (declare (type double-double-float x) + (optimize (speed 3) (space 0) + (inhibit-warnings 3))) + (multiple-value-bind (x e) + (decode-float x) + (declare (type double-double-float x) + (type double-float-exponent e)) + (let ((z 0w0) + (y 0w0)) + (declare (type double-double-float z y)) + (cond ((or (> e 2) + (< e -2)) + (cond ((< x sqrt-1/2) + ;; 2*(2*x-1)/(2*x+1) + (decf e) + (setf z (- x 0.5w0)) + (setf y (+ (* 0.5w0 z) 0.5w0))) + (t + ;; 2*(x-1)/(x+1) + (setf z (- x 0.5w0)) + (decf z 0.5w0) + (setf y (+ (* 0.5w0 x) 0.5w0)))) + (setf x (/ z y)) + (setf z (* x x)) + (setf y (* x (/ (* z (poly-eval z r)) + (poly-eval-1 z s))))) + (t + (cond ((< x sqrt-1/2) + (decf e) + (setf x (- (scale-float x 1) 1))) + (t + (decf x))) + (setf z (* x x)) + (setf y (* x (/ (* z (poly-eval x p)) + (poly-eval-1 x q)))) + (decf y (scale-float z -1)))) + (values e x y z))))) + (defun dd-%log2 (x) (declare (type double-double-float x) (optimize (speed 3) (space 0) (inhibit-warnings 3))) - (multiple-value-bind (x e) - (decode-float x) - (declare (type double-double-float x) - (type double-float-exponent e)) - (let ((z 0w0) - (y 0w0)) - (declare (type double-double-float z y)) - (cond ((or (> e 2) - (< e -2)) - (cond ((< x sqrt-1/2) - ;; 2*(2*x-1)/(2*x+1) - (decf e) - (setf z (- x 0.5w0)) - (setf y (+ (* 0.5w0 z) 0.5w0))) - (t - ;; 2*(x-1)/(x+1) - (setf z (- x 0.5w0)) - (decf z 0.5w0) - (setf y (+ (* 0.5w0 z) 0.5w0)))) - (setf x (/ z y)) - (setf z (* x x)) - (setf y (* x (/ (* z (poly-eval z r)) - (poly-eval-1 z s))))) - (t - (cond ((< x sqrt-1/2) - (decf e) - (setf x (- (scale-float x 1) 1))) - (t - (decf x))) - (setf z (* x x)) - (setf y (* x (/ (* z (poly-eval x p)) - (poly-eval-1 x q)))) - (decf y (scale-float z -1)))) - ;; Multiply log of fraction by log2(e) and base 2 exponent by 1 - ;; - ;; This sequence of operations is critical - (setf z (* y log2ea)) - (setf z (+ z (* x log2ea))) - (setf z (+ z y)) - (setf z (+ z x)) - (setf z (+ z e)) - z)))) + (when (eql x 0w0) + ;; log2(+0) = -infinity + (return-from dd-%log2 (/ -1 x))) + (multiple-value-bind (e x y z) + (compute-log x) + ;; Multiply log of fraction by log2(e) and base 2 exponent by 1 + ;; + ;; This sequence of operations is critical + (setf z (* y log2ea)) + (incf z (* x log2ea)) + (incf z y) + (incf z x) + (incf z e) + z)) + + (defun dd-%log10 (x) + (declare (type double-double-float x) + (optimize (speed 3) (space 0) + (inhibit-warnings 3))) + (when (eql x 0w0) + ;; log2(+0) = -infinity + (return-from dd-%log10 (/ -1 x))) + (multiple-value-bind (e x y z) + (compute-log x) + ;; Multiply log of fraction by log10(e) and base 2 exponent by log10(2). + ;; + ;; This sequence of operations is critical. + (setf z (* y l10eb)) + (incf z (* x l10eb)) + (incf z (* e l102b)) + (incf z (* y l10ea)) + (incf z (* x l10ea)) + (incf z (* e l102a)) + z)))) ;;; dd-%exp2 ;;; 2^x diff --git a/src/code/irrat.lisp b/src/code/irrat.lisp index 8ddd4138161d1ea7d12e0afeb40da6337af9cedf..b21b92fbcebb0c2851722944e6c3b9e1d2d55a5c 100644 --- a/src/code/irrat.lisp +++ b/src/code/irrat.lisp @@ -82,6 +82,7 @@ (def-math-rtn ("__ieee754_exp" %exp) 1) (def-math-rtn ("__ieee754_log" %log) 1) (def-math-rtn ("__ieee754_log10" %log10) 1) +(def-math-rtn ("cmucl_log2" %log2) 1) (def-math-rtn ("__ieee754_pow" %pow) 2) #-(or x86 sparc-v7 sparc-v8 sparc-v9) @@ -631,8 +632,11 @@ ;; it, and converting it to double-float is accurate. (if (= (integer-length top) (integer-length bot)) - (/ (log1p (float (- x 1) float-type)) - (log-of-2 float-type)) + (let ((log-abs (/ (log1p (float (- (abs x) 1) float-type)) + (log-of-2 float-type)))) + (if (minusp x) + (complex log-abs (log-2-pi float-type)) + log-abs)) (multiple-value-bind (top-n top-frac) (log2-bignum top) (multiple-value-bind (bot-n bot-frac) @@ -644,6 +648,19 @@ (log2-bignum x) (+ n frac)))))) +;; Handle the case where number could be so large that it doesn't fit +;; in a double-float. +(defun log10 (number &optional (float-type 1d0)) + (let ((d (ignore-errors (float number 1d0)))) + (cond (d + ;; Number fits in a double, so it's easy + (float (%log10 d) float-type)) + (t + ;; Number doesn't fit in a double. Do it the hard way using + ;; log2. This should be done more accurately. + (float (/ (log2 number) + (log2 10)) float-type))))) + (defun log (number &optional (base nil base-p)) "Return the logarithm of NUMBER in the base BASE, which defaults to e." (if base-p @@ -653,27 +670,44 @@ ((and (realp number) (realp base)) (cond ((and (= base 2) - (floatp number) - #+double-double - (not (typep number 'ext:double-double-float)) + ;;(floatp number) (or (plusp number) (eql number 0.0) - (eql number 0d0))) - ;; Do the same thing as the deftranform does for - ;; log base 2 and 10 for non-negative arguments. + (eql number 0d0) + #+double-double + (eql number 0w0))) + ;; Do the same thing as the deftranform does for log + ;; base 2 and 10 for non-negative arguments: handle + ;; the case where number > 0 or equal to +0. (number-dispatch ((number real) (base real)) ((double-float - (foreach integer single-float double-float)) - (log2 number)) - ((single-float - (foreach integer single-float)) - (float (log2 (float number 1d0)) 1f0)) + (foreach integer ratio single-float double-float)) + (%log2 number)) ((single-float double-float) - (log2 (float number 1d0))))) + (%log2 (float number 1d0))) + ((single-float + (foreach integer ratio single-float)) + (float (%log2 (float number 1d0)) 1f0)) + (((foreach integer ratio) + (foreach integer ratio single-float)) + (float (log2 number) 1f0)) + (((foreach integer ratio) + double-float) + (log2 number)) + #+double-double + (((foreach single-float double-float) + double-double-float) + (dd-%log2 (float number 1w0))) + #+double-double + (((foreach integer ratio) + double-double-float) + (log2 number 1w0)) + #+double-double + ((double-double-float + (foreach integer ratio single-float double-float double-double-float)) + (dd-%log2 number)))) ((and (= base 10) - (floatp number) - #+double-double - (not (typep number 'double-double-float)) + ;;(floatp number) (or (plusp number) (eql number 0.0) (eql number 0d0))) @@ -681,13 +715,31 @@ ;; log base 2 and 10 for non-negative arguments. (number-dispatch ((number real) (base real)) ((double-float - (foreach double-float single-float integer)) + (foreach integer ratio single-float double-float)) (%log10 number)) + ((single-float double-float) + (%log10 (float number 1d0))) ((single-float - (foreach single-float integer)) + (foreach integer ratio single-float)) (float (%log10 (float number 1d0)) 1f0)) - ((single-float double-float) - (%log10 (float number 1d0))))) + (((foreach integer ratio) + (foreach integer ratio single-float)) + (log10 number 1f0)) + (((foreach integer ratio) + double-float) + (log10 number 1d0)) + #+double-double + (((foreach integer ratio) + ext:double-double-float) + (log10 number 1w0)) + #+double-double + (((foreach single-float double-float) + ext:double-double-float) + (dd-%log10 (float number 1w0))) + #+double-double + ((double-double-float + (foreach integer ratio single-float double-float double-double-float)) + (dd-%log10 number)))) (t ;; CLHS 12.1.4.1 says ;; @@ -729,11 +781,14 @@ #+double-double ((double-double-float (foreach fixnum bignum ratio)) + ;; Use log2 in case the base is so large that it + ;; won't fit in a float. (/ (log2 number 1w0) (log2 base 1w0))) #+double-double ((double-double-float (foreach double-double-float double-float single-float)) - (/ (log number) (log (coerce base 'double-double-float)))) + (/ (log number) + (log (coerce base 'double-double-float)))) #+double-double (((foreach fixnum bignum ratio) double-double-float) diff --git a/src/compiler/float-tran.lisp b/src/compiler/float-tran.lisp index 6efe7019d910b6c492b58eaf160367416bca61fd..c30e3f785c4a04185fb930f85643dff4a059c159 100644 --- a/src/compiler/float-tran.lisp +++ b/src/compiler/float-tran.lisp @@ -865,7 +865,7 @@ (cond ((= y-val 10) `(coerce (kernel:%log10 (float x 1d0)) 'single-float)) ((= y-val 2) - `(coerce (kernel::log2 (float x 1d0)) 'single-float))))) + `(coerce (kernel:%log2 (float x 1d0)) 'single-float))))) (deftransform log ((x y) ((or (member 0d0) (double-float 0d0)) (constant-argument number)) @@ -879,7 +879,7 @@ (cond ((= y-val 10) `(kernel:%log10 (float x 1d0))) ((= y-val 2) - `(kernel::log2 (float x 1d0)))))) + `(kernel:%log2 (float x 1d0)))))) ;;; Handle some simple transformations diff --git a/src/compiler/ppc/float.lisp b/src/compiler/ppc/float.lisp index c5c944bd46d06cb17ffc9ff1e96a5ef6ea049101..e9286196534cd8470f3a7adaf5c31469291a4be4 100644 --- a/src/compiler/ppc/float.lisp +++ b/src/compiler/ppc/float.lisp @@ -938,6 +938,63 @@ (defknown ((setf floating-point-modes)) (float-modes) float-modes) +(defun describe-floating-point-modes (&optional (modes (floating-point-modes))) + "Print a description of each bit of the floating point modes in MODES." + (format t "31 FX = ~B FP exception summary~%" + (ldb (byte 1 31) modes)) + (format t "30 FEX = ~B FP enabled exception summary~%" + (ldb (byte 1 30) modes)) + (format t "29 VX = ~B FP invalid operation exception summary~%" + (ldb (byte 1 29) modes)) + (format t "28 OX = ~B FP overflow exception (sticky)~%" + (ldb (byte 1 28) modes)) + (format t "27 UX = ~B FP underflow exception (sticky)~%" + (ldb (byte 1 27) modes)) + (format t "26 ZX = ~B FP zero divide exception (sticky)~%" + (ldb (byte 1 26) modes)) + (format t "25 XX = ~B FP inexact exception (sticky)~%" + (ldb (byte 1 25) modes)) + (format t "24 VXSNAN = ~B FP invalid operation with SNaN (sticky)~%" + (ldb (byte 1 24) modes)) + (format t "23 VXISI = ~B FP invalid operation for inf - inf (sticky)~%" + (ldb (byte 1 23) modes)) + (format t "22 VXIDI = ~B FP invalid operation for inf + inf (sticky)~%" + (ldb (byte 1 22) modes)) + (format t "21 VXZDZ = ~B FP invalid operation for 0/0 (sticky)~%" + (ldb (byte 1 21) modes)) + (format t "20 VXIMZ = ~B FP invalid operation for inf * 0 (sticky)~%" + (ldb (byte 1 20) modes)) + (format t "19 VXVC = ~B FP invalid operation for invalid compare (sticky)~%" + (ldb (byte 1 19) modes)) + (format t "18 FR = ~B FP fraction rounded~%" + (ldb (byte 1 18) modes)) + (format t "17 FI = ~B FP fraction inexact~%" + (ldb (byte 1 17) modes)) + (format t "12 FPRF = ~5,'0B FP result flags~%" + (ldb (byte 5 12) modes)) + (format t "11 Reserved~%") + (format t "10 VXSOFT = ~B FP invalid operation for software request (sticky)~%" + (ldb (byte 1 10) modes)) + (format t " 9 VXSQRT = ~B FP invalid operation for sqrt (sticky)~%" + (ldb (byte 1 9) modes)) + (format t " 8 VXCVI = ~B FP invalid operation for integer convert (sticky)~%" + (ldb (byte 1 8) modes)) + (format t " 7 VE = ~B FP invalid operation exception enable~%" + (ldb (byte 1 7) modes)) + (format t " 6 OE = ~B FP overflow exception enable~%" + (ldb (byte 1 6) modes)) + (format t " 5 UE = ~B FP underflow exception enable~%" + (ldb (byte 1 5) modes)) + (format t " 4 ZE = ~B FP zero divide exception enable~%" + (ldb (byte 1 4) modes)) + (format t " 3 XE = ~B FP inexact operation enable~%" + (ldb (byte 1 3) modes)) + (format t " 2 NI = ~B FP non-IEEE mode enable~%" + (ldb (byte 1 2) modes)) + (format t " 0 RN = ~2,'0B FP rounding control + (00 = nearest, 01 = zero, 10 = +inf, 11 = -inf~%" + (ldb (byte 2 0) modes))) + (define-vop (floating-point-modes) (:results (res :scs (unsigned-reg))) (:result-types unsigned-num) diff --git a/src/compiler/ppc/parms.lisp b/src/compiler/ppc/parms.lisp index dab5ce5130b7c530ddf81388d3bebd91447bd249..dda73ebc546070fdb616a937628aed8d6ce5537a 100644 --- a/src/compiler/ppc/parms.lisp +++ b/src/compiler/ppc/parms.lisp @@ -66,7 +66,9 @@ float-underflow-trap-bit float-overflow-trap-bit float-imprecise-trap-bit float-invalid-trap-bit float-divide-by-zero-trap-bit - float-invalid-op-1-byte)) + float-invalid-op-1-byte + float-invalid-op-2-byte + float-exceptions-summary-byte)) #+double-double (export '(double-double-float-digits)) @@ -152,6 +154,10 @@ ;; operation such as some software request, invalid square root, or ;; invalid integer convert. (defconstant float-invalid-op-2-byte (byte 3 8)) +;; FP exception summary bit. This is set if an FP instruction causes +;; any of the FP exception bits to transition from 0 to 1 (meaning +;; that exception occurred.) +(defconstant float-exceptions-summary-byte (byte 1 31)) (defconstant float-fast-bit (ash 1 2)) ; Non-IEEE mode ); eval-when diff --git a/src/i18n/locale/en@piglatin/LC_MESSAGES/cmucl.po b/src/i18n/locale/en@piglatin/LC_MESSAGES/cmucl.po index df7d5b1897492c0473d540651e07e246bf6a0fe2..6eb940470ef171273e6c2a55791544e3a5b41964 100644 --- a/src/i18n/locale/en@piglatin/LC_MESSAGES/cmucl.po +++ b/src/i18n/locale/en@piglatin/LC_MESSAGES/cmucl.po @@ -5176,6 +5176,29 @@ msgstr "" "ethay ighhay orway owlay\n" " urrogatesay aluevay, espectivelyray." +#: src/code/string.lisp +#, fuzzy +msgid "" +"WITH-STRING-CODEPOINT-ITERATOR ((next string) &body body)\n" +" provides a method of looping through a string from the beginning to\n" +" the end of the string prodcucing successive codepoints from the\n" +" string. NEXT is bound to a generator macro that, within the scope\n" +" of the invocation, returns one or two values. The first value tells\n" +" whether any objects remain in the string. When the first value is\n" +" non-NIL, the second value is the codepoint of the next object." +msgstr "" +"WITH-HASH-TABLE-ITERATOR ((unctionfay ashhay-abletay) &odybay odybay)\n" +" ovidespray away ethodmay ofway anuallymay oopinglay overway ethay " +"elementsway ofway away ashhay-abletay.\n" +" FUNCTION isway oundbay otay away eneratorgay-acromay atthay, ithinway " +"ethay opescay ofway ethay\n" +" invocationway, eturnsray oneway orway reethay aluesvay. Ethay irstfay " +"aluevay ellstay etherwhay\n" +" anyway objectsway emainray inway ethay ashhay abletay. Enwhay ethay " +"irstfay aluevay isway onnay-NIL, \n" +" ethay econdsay andway irdthay aluesvay areway ethay eykay andway ethay " +"aluevay ofway ethay extnay objectway." + #: src/code/string.lisp msgid "" "Return the high and low surrogate characters for Codepoint. If\n" @@ -5619,6 +5642,30 @@ msgstr "" "amesay asway GLYPH,\n" " exceptway atthay ethay ingstray ustmay ebay away implesay-ingstray" +#: src/code/string.lisp +#, fuzzy +msgid "" +"WITH-STRING-GLYPH-ITERATOR ((next string) &body body)\n" +" provides a method of looping through a string from the beginning to\n" +" the end of the string prodcucing successive glyphs from the string.\n" +" NEXT is bound to a generator macro that, within the scope of the\n" +" invocation, returns one or three values. The first value tells\n" +" whether any objects remain in the string. When the first value is\n" +" non-NIL, the second value is the index into the string of the glyph\n" +" and the third value is index of the next glyph." +msgstr "" +"WITH-HASH-TABLE-ITERATOR ((unctionfay ashhay-abletay) &odybay odybay)\n" +" ovidespray away ethodmay ofway anuallymay oopinglay overway ethay " +"elementsway ofway away ashhay-abletay.\n" +" FUNCTION isway oundbay otay away eneratorgay-acromay atthay, ithinway " +"ethay opescay ofway ethay\n" +" invocationway, eturnsray oneway orway reethay aluesvay. Ethay irstfay " +"aluevay ellstay etherwhay\n" +" anyway objectsway emainray inway ethay ashhay abletay. Enwhay ethay " +"irstfay aluevay isway onnay-NIL, \n" +" ethay econdsay andway irdthay aluesvay areway ethay eykay andway ethay " +"aluevay ofway ethay extnay objectway." + #: src/code/string.lisp msgid "" "Convert String to Unicode Normalization Form D (NFD) using the\n" @@ -19092,6 +19139,18 @@ msgid "Destructuring is not valid for package symbol iteration." msgstr "" "Estructuringday isway otnay alidvay orfay ackagepay ymbolsay iterationway." +#: src/code/loop.lisp +#, fuzzy +msgid "Destructuring is not valid for string codepoint iteration." +msgstr "" +"Estructuringday isway otnay alidvay orfay ackagepay ymbolsay iterationway." + +#: src/code/loop.lisp +#, fuzzy +msgid "Destructuring is not valid for string glyph iteration." +msgstr "" +"Estructuringday isway otnay alidvay orfay ackagepay ymbolsay iterationway." + #: src/code/stream-vector-io.lisp msgid "endian-swap ~a is illegal for element-type of vector ~a" msgstr "" diff --git a/src/i18n/locale/ko/LC_MESSAGES/cmucl.po b/src/i18n/locale/ko/LC_MESSAGES/cmucl.po index b73bf6a1dc57d42a125e67f703066da9e0283004..a8c6a23c93f2a087b80feb09e89fa455105911d4 100644 --- a/src/i18n/locale/ko/LC_MESSAGES/cmucl.po +++ b/src/i18n/locale/ko/LC_MESSAGES/cmucl.po @@ -3702,6 +3702,17 @@ msgid "" " surrogate value, respectively." msgstr "" +#: src/code/string.lisp +msgid "" +"WITH-STRING-CODEPOINT-ITERATOR ((next string) &body body)\n" +" provides a method of looping through a string from the beginning to\n" +" the end of the string prodcucing successive codepoints from the\n" +" string. NEXT is bound to a generator macro that, within the scope\n" +" of the invocation, returns one or two values. The first value tells\n" +" whether any objects remain in the string. When the first value is\n" +" non-NIL, the second value is the codepoint of the next object." +msgstr "" + #: src/code/string.lisp msgid "" "Return the high and low surrogate characters for Codepoint. If\n" @@ -3960,6 +3971,18 @@ msgid "" " except that the string must be a simple-string" msgstr "" +#: src/code/string.lisp +msgid "" +"WITH-STRING-GLYPH-ITERATOR ((next string) &body body)\n" +" provides a method of looping through a string from the beginning to\n" +" the end of the string prodcucing successive glyphs from the string.\n" +" NEXT is bound to a generator macro that, within the scope of the\n" +" invocation, returns one or three values. The first value tells\n" +" whether any objects remain in the string. When the first value is\n" +" non-NIL, the second value is the index into the string of the glyph\n" +" and the third value is index of the next glyph." +msgstr "" + #: src/code/string.lisp msgid "" "Convert String to Unicode Normalization Form D (NFD) using the\n" @@ -13414,6 +13437,14 @@ msgstr "" msgid "Destructuring is not valid for package symbol iteration." msgstr "" +#: src/code/loop.lisp +msgid "Destructuring is not valid for string codepoint iteration." +msgstr "" + +#: src/code/loop.lisp +msgid "Destructuring is not valid for string glyph iteration." +msgstr "" + #: src/code/stream-vector-io.lisp msgid "endian-swap ~a is illegal for element-type of vector ~a" msgstr "" diff --git a/src/lisp/Config.sparc_common b/src/lisp/Config.sparc_common index 9a7c850b2d66e797156b33cdeaab02f0bbf4cf09..55204c09bd604b0037cd7e777b3361a51c413714 100644 --- a/src/lisp/Config.sparc_common +++ b/src/lisp/Config.sparc_common @@ -60,6 +60,6 @@ ASSEM_SRC = sparc-assem.S ARCH_SRC = sparc-arch.c DEPEND=$(CC) -OS_SRC = solaris-os.c os-common.c undefineds.c elf.c +OS_SRC = solaris-os.c os-common.c elf.c OS_LIBS= -lsocket -lnsl -ldl EXEC_FINAL_OBJ = exec-final.o diff --git a/src/lisp/Darwin-os.c b/src/lisp/Darwin-os.c index e1120ab8edef1518e1e2acf22305cbf7960306ec..53d2db591103528e30912205bb4a89aae1ef7a7f 100644 --- a/src/lisp/Darwin-os.c +++ b/src/lisp/Darwin-os.c @@ -534,7 +534,7 @@ os_dlsym(const char *sym_name, lispobj lib_list) void *sym_addr = 0; int offset = sym_name[0] == '_' ? 1 : 0; -#if 1 +#if 0 if (offset == 0) { fprintf(stderr, "sym-name = %s\n", sym_name); } diff --git a/src/lisp/GNUmakefile b/src/lisp/GNUmakefile index d8fb69002dcc6352825cbb29c71e1385bce50ae3..ad9b47249457daab770f4c9adc751bbe9c45cf32 100644 --- a/src/lisp/GNUmakefile +++ b/src/lisp/GNUmakefile @@ -13,7 +13,8 @@ FDLIBM = k_sin.c k_cos.c k_tan.c s_sin.c s_cos.c s_tan.c sincos.c \ e_atan2.c \ e_rem_pio2.c k_rem_pio2.c \ e_log10.c s_scalbn.c \ - setexception.c + setexception.c \ + log2.c SRCS = lisp.c coreparse.c alloc.c monitor.c print.c interr.c \ vars.c parse.c interrupt.c search.c validate.c globals.c \ @@ -48,10 +49,10 @@ lisp: ${OBJS} version.o # builtin_image_flag to 1 so that the runtime knows the runtime # contains the core sections. lisp.a: version.o ${OBJS} ${EXEC_FINAL_OBJ} - ar crs lisp.a ${OBJS} version.o + $(AR) crs lisp.a ${OBJS} version.o ifneq (${EXEC_FINAL_OBJ},) - ar d lisp.a exec-init.o - ar r lisp.a ${EXEC_FINAL_OBJ} + $(AR) d lisp.a exec-init.o + $(AR) r lisp.a ${EXEC_FINAL_OBJ} endif version: @@ -62,7 +63,7 @@ internals.h internals.inc: @false clean: - rm -f Depends *.o lisp lisp.nm core + $(RM) Depends *.o lisp lisp.nm core lisp.a echo 'Map file for lisp version 0' > lisp.nm depend: Depends diff --git a/src/lisp/log2.c b/src/lisp/log2.c new file mode 100644 index 0000000000000000000000000000000000000000..d56bc43242bec3270aaa0c46d54cebacb2111f2f --- /dev/null +++ b/src/lisp/log2.c @@ -0,0 +1,139 @@ +/* + * ==================================================== + * Copyright (C) 2004 by Sun Microsystems, Inc. All rights reserved. + * + * Permission to use, copy, modify, and distribute this + * software is freely granted, provided that this notice + * is preserved. + * ==================================================== + */ + +/* + * This is the log2 algorithm pulled out of __ieee754_pow in e_pow.c + */ + +/* + * Method: Let x = 2 * (1+f) + * 1. Compute and return log2(x) in two pieces: + * log2(x) = w1 + w2, + * where w1 has 53-24 = 29 bit trailing zeros. + */ + +#include "fdlibm.h" + +static double +bp[] = {1.0, 1.5,}, +dp_h[] = { 0.0, 5.84962487220764160156e-01,}, /* 0x3FE2B803, 0x40000000 */ +dp_l[] = { 0.0, 1.35003920212974897128e-08,}, /* 0x3E4CFDEB, 0x43CFD006 */ +zero = 0.0, +one = 1.0, +two53 = 9007199254740992.0, /* 0x43400000, 0x00000000 */ + /* poly coefs for (3/2)*(log(x)-2s-2/3*s**3 */ +L1 = 5.99999999999994648725e-01, /* 0x3FE33333, 0x33333303 */ +L2 = 4.28571428578550184252e-01, /* 0x3FDB6DB6, 0xDB6FABFF */ +L3 = 3.33333329818377432918e-01, /* 0x3FD55555, 0x518F264D */ +L4 = 2.72728123808534006489e-01, /* 0x3FD17460, 0xA91D4101 */ +L5 = 2.30660745775561754067e-01, /* 0x3FCD864A, 0x93C9DB65 */ +L6 = 2.06975017800338417784e-01, /* 0x3FCA7E28, 0x4A454EEF */ +cp = 9.61796693925975554329e-01, /* 0x3FEEC709, 0xDC3A03FD =2/(3ln2) */ +cp_h = 9.61796700954437255859e-01, /* 0x3FEEC709, 0xE0000000 =(float)cp */ +cp_l = -7.02846165095275826516e-09; /* 0xBE3E2FE0, 0x145B01F5 =tail of cp_h*/ + +double cmucl_log2(double x) +{ + double ax; + int k, hx, lx, ix; + union { int i[2]; double d; } ux; + + ux.d = x; + hx = ux.i[HIWORD]; lx = ux.i[LOWORD]; + ix = hx&0x7fffffff; + + ax = fabs(x); + + /* special value of x */ + + if (hx < 0x00100000) { /* x < 2**-1022 */ + if (((hx&0x7fffffff)|lx)==0) { + /* log(+-0)=-inf */ + return fdlibm_setexception(-1.0, FDLIBM_DIVIDE_BY_ZERO); + } + + if (hx<0) { + /* log(-#) = NaN */ + return fdlibm_setexception(x, FDLIBM_INVALID); + } + } + + { + double ss,s2,s_h,s_l,t_h,t_l; + double z_h,z_l,p_h,p_l; + double r, u, v, t, t1, t2; + int n, j; + + n = 0; + /* take care subnormal number */ + if(ix<0x00100000) { + ax *= two53; + n -= 53; + ux.d = ax; + ix = ux.i[HIWORD]; + } + n += ((ix)>>20)-0x3ff; + j = ix&0x000fffff; + /* determine interval */ + ix = j|0x3ff00000; /* normalize ix */ + if(j<=0x3988E) k=0; /* |x|<sqrt(3/2) */ + else if(j<0xBB67A) k=1; /* |x|<sqrt(3) */ + else {k=0;n+=1;ix -= 0x00100000;} + ux.d = ax; + ux.i[HIWORD] = ix; + ax = ux.d; + + /* compute ss = s_h+s_l = (x-1)/(x+1) or (x-1.5)/(x+1.5) */ + u = ax-bp[k]; /* bp[0]=1.0, bp[1]=1.5 */ + v = one/(ax+bp[k]); + ss = u*v; + s_h = ss; + ux.d = s_h; + ux.i[LOWORD] = 0; + s_h = ux.d; + /* t_h=ax+bp[k] High */ + t_h = zero; + ux.d = t_h; + ux.i[HIWORD]=((ix>>1)|0x20000000)+0x00080000+(k<<18); + t_h = ux.d; + t_l = ax - (t_h-bp[k]); + s_l = v*((u-s_h*t_h)-s_h*t_l); + /* compute log(ax) */ + s2 = ss*ss; + r = s2*s2*(L1+s2*(L2+s2*(L3+s2*(L4+s2*(L5+s2*L6))))); + r += s_l*(s_h+ss); + s2 = s_h*s_h; + t_h = 3.0+s2+r; + ux.d = t_h; + ux.i[LOWORD] = 0; + t_h = ux.d; + t_l = r-((t_h-3.0)-s2); + /* u+v = ss*(1+...) */ + u = s_h*t_h; + v = s_l*t_h+t_l*ss; + /* 2/(3log2)*(ss+...) */ + p_h = u+v; + ux.d = p_h; + ux.i[LOWORD] = 0; + p_h = ux.d; + p_l = v-(p_h-u); + z_h = cp_h*p_h; /* cp_h+cp_l = 2/(3*log2) */ + z_l = cp_l*p_h+p_l*cp+dp_l[k]; + /* log2(ax) = (ss+..)*2/(3*log2) = n + dp_h + z_h + z_l */ + t = (double)n; + t1 = (((z_h+z_l)+dp_h[k])+t); + ux.d = t1; + ux.i[LOWORD] = 0; + t1 = ux.d; + t2 = z_l-(((t1-t)-dp_h[k])-z_h); + + return t1 + t2; + } +} diff --git a/src/pcl/std-class.lisp b/src/pcl/std-class.lisp index 1d4049dcd0dc12be659f4a583da25d3d815d7e68..3f247f2957fa08dc9d310eb218a9fcbe94f82c7b 100644 --- a/src/pcl/std-class.lisp +++ b/src/pcl/std-class.lisp @@ -435,7 +435,12 @@ slot-name) else do (loop for (option value . more) on slot by #'cddr - if (and (member option '(:allocation :type :initform + if (and (eq option :allocation) + (not (member value '(:class :instance)))) do + (simple-program-error + "~@<Slot ~S: :allocation value must be :class or :instance, not ~S~@:>" + slot-name value) + else if (and (member option '(:type :initform :documentation)) (not (eq unsupplied (getf more option unsupplied)))) do diff --git a/src/tools/linker.sh b/src/tools/linker.sh index f97dcf455c0616b835d92242f24eab259907ffb9..a5a99ef66d9a8a3181d6eb25e1cd9300d55d51fa 100755 --- a/src/tools/linker.sh +++ b/src/tools/linker.sh @@ -94,15 +94,22 @@ case $uname_s in # up, so we move it to another address. This seems to be # free, at least on 10.5. - OPT_EXTRA="-segaddr __LINKEDIT 0x99000000 -rdynamic" + # Also specify the min version. (See Config.x86_darwin for + # the desired version.) This gets rid of a PIE warning + # when creating the executable on 10.8. (See ticket:112.) + + OPT_EXTRA="-segaddr __LINKEDIT 0x99000000 -rdynamic -mmacosx-version-min=10.5" + OS_LIBS= ;; powerpc) - # Nothing needed for ppc? + # See Config.ppc_darwin Like i386, __LINKEDIT is linked + # just after the dynamic space which messes things up, so + # we move it to a diffferent address. The address below + # appears to be free. + OPT_EXTRA="-segaddr __LINKEDIT 0x99000000 -mmacosx-version-min=10.4 -static-libgcc" + OS_LIBS="-lSystem -lc -lm" ;; esac - - # See Config.x86_darwin - OS_LIBS= ;; SunOS) # A quick test indicates that gcc will accept the following diff --git a/tests/irrat.lisp b/tests/irrat.lisp new file mode 100644 index 0000000000000000000000000000000000000000..14db13eebbbb38da3701851f15b037ad08e5afe2 --- /dev/null +++ b/tests/irrat.lisp @@ -0,0 +1,154 @@ +;; Tests of special irrational functions + +(defpackage :irrat-tests + (:use :cl :lisp-unit)) + +(in-package "IRRAT-TESTS") + +(defun relerr (actual expected) + (/ (abs (- actual expected)) + expected)) + +;; This tests that log base 2 returns the correct value and the +;; correct type. +(define-test log2.result-types + (dolist (number '(4 4f0 4d0 #+double-double 4w0)) + (dolist (base '(2 2f0 2d0 #+double-double 2w0)) + ;; This tests that log returns the correct value and the correct type. + (let* ((result (log number base)) + (true-type (etypecase number + ((or integer single-float) + (etypecase base + ((or integer single-float) 'single-float) + (double-float 'double-float) + #+double-double + (ext:double-double-float 'ext:double-double-float))) + (double-float + (etypecase base + ((or integer single-float double-float) + 'double-float) + #+double-double + (ext:double-double-float 'ext:double-double-float))) + #+double-double + (ext:double-double-float + 'ext:double-double-float)))) + (assert-equal (coerce 2 true-type) result + number base) + (assert-true (typep result true-type) + result true-type))))) + +(define-test log2.special-cases + (let* ((y (log 3/2 2)) + (e (relerr y 0.5849625007211562d0))) + (assert-true (<= e + 2.308d-8) + e y)) + (let* ((y (log -3/2 2)) + (ry (realpart y)) + (iy (imagpart y)) + (er (relerr ry 0.5849625007211562d0)) + (ei (relerr iy (/ pi (log 2d0))))) + (assert-true (<= er 2.308d-8) + er ry) + (assert-true (<= ei 1.433d-8) + ei iy))) + +;; This tests that log base 10 returns the correct value and the +;; correct type. +(define-test log10.result-types + (dolist (number '(100 100f0 100d0 #+double-double 100w0)) + (dolist (base '(10 10f0 10d0 #+double-double 10w0)) + ;; This tests that log returns the correct value and the correct type. + (let* ((result (log number base)) + (true-type + (etypecase number + ((or integer single-float) + (etypecase base + ((or integer single-float) + 'single-float) + (double-float + 'double-float) + #+double-double + (ext:double-double-float + 'ext:double-double-float))) + (double-float + (etypecase base + ((or integer single-float double-float) + 'double-float) + #+double-double + (ext:double-double-float + 'ext:double-double-float))) + #+double-double + (ext:double-double-float + 'ext:double-double-float)))) + (assert-equalp 2 result + number base result) + (assert-true (typep result true-type) + number base result true-type))))) + +(define-test dd-log2.special-cases + ;; Verify that for x = 10^k for k = 1 to 300 that (kernel::dd-%log2 + ;; x) is close to the expected value. Previously, a bug caused + ;; (kernel::dd-%log2 100w0) to give 6.1699... instead of 6.64385. + (loop for k from 1 below 300 + for x = (expt 10 k) + for y = (kernel::dd-%log2 (float x 1w0)) + for z = (/ (log (float x 1d0)) (log 2d0)) + for e = (/ (abs (- y z)) z) + do (assert-true (<= e 2d-16) + k y z e)) + (let ((y (kernel::dd-%log2 (sqrt 2w0)))) + (assert-true (<= (relerr y 1/2) + (* 2.7 (scale-float 1d0 (- (float-digits 1w0))))) + y)) + (let ((y (kernel::dd-%log2 (sqrt 0.5w0)))) + (assert-true (<= (relerr y -1/2) + (* 2.7 (scale-float 1d0 (- (float-digits 1w0))))) + y)) + (assert-true (typep (log (ash 1 3000) 2) 'single-float)) + (assert-true (typep (log (ash 1 3000) 2f0) 'single-float)) + (assert-true (typep (log (ash 1 3000) 2d0) 'double-float)) + (assert-true (typep (log (ash 1 3000) 2w0) 'ext:double-double-float))) + + +(define-test dd-log2.powers-of-2 + (loop for k from -1074 below 1024 + for x = (scale-float 1w0 k) + for y = (kernel::dd-%log2 x) + do (assert-equalp k y + k x y))) + +(define-test dd-log10.special-cases + (let ((y (kernel::dd-%log10 (sqrt 10w0)))) + (assert-true (<= (relerr y 1/2) + (* 0.25 (scale-float 1d0 (- (float-digits 1w0))))))) + (assert-true (typep (log (ash 1 3000) 10) 'single-float)) + (assert-true (typep (log (ash 1 3000) 10f0) 'single-float)) + (assert-true (typep (log (ash 1 3000) 10d0) 'double-float)) + (assert-true (typep (log (ash 1 3000) 10w0) 'ext:double-double-float))) + +(define-test dd-log10.powers-of-ten + ;; It would be nice if dd-%log10 produce the exact result for powers + ;; of ten, but we currently don't. But note that the maximum + ;; relative error is less than a double-double epsilon. + (let ((threshold (* 0.109 (scale-float 1d0 (- (float-digits 1w0)))))) + (loop for k from -323 below 0 + for x = (expt 10 k) + for y = (kernel::dd-%log10 (float x 1w0)) + for e = (relerr y k) + do (assert-true (<= e threshold) + k e x y)) + (loop for k from 1 to 308 + for x = (expt 10 k) + for y = (kernel::dd-%log10 (float x 1w0)) + for e = (relerr y k) + do (assert-true (<= e threshold) + k e x y)))) + + +(define-test log2.relationships + (loop for k from 1 below 1000 + for x = (expt 1.1w0 k) + for logx = (kernel::dd-%log2 x) + for log1/x = (kernel::dd-%log2 (/ x)) + do (assert-true (<= (abs (+ logx log1/x)) (* 1 double-float-epsilon))))) diff --git a/tests/pcl/defgeneric.lisp b/tests/pcl/defgeneric.lisp index 05f01c7f03502912c82ac40959dc5708569383b5..2cf9e070e509b58387ca36cefa22419e4d3cb031 100644 --- a/tests/pcl/defgeneric.lisp +++ b/tests/pcl/defgeneric.lisp @@ -32,13 +32,12 @@ (in-package "PCL-TESTS") +;; These errors are signaled during macroexpansion of the defgeneric +;; form so catch the errors during macroexpansion. (defmacro define-gf-lambda-list-test (name lambda-list) - `(deftest ,name - (multiple-value-bind (r c) - (ignore-errors - (defgeneric g ,lambda-list)) - (values (null r) (typep c 'error))) - t t)) + `(define-test ,name + (assert-error 'program-error + (macroexpand '(defgeneric g ,lambda-list))))) (define-gf-lambda-list-test defgeneric-lambda-list.0 (a &optional (b 1))) (define-gf-lambda-list-test defgeneric-lambda-list.1 (a &key (b 1))) diff --git a/tests/trac.lisp b/tests/trac.lisp index 2bf420d85d4b747e198704c6bd8715bb1242e2df..198a24de19dfd693821c057b327713c58c8163c5 100644 --- a/tests/trac.lisp +++ b/tests/trac.lisp @@ -22,7 +22,7 @@ (:tag :trac) (assert-false (let (failures) - (dolist (base (list nil 2 2.0 2d0 + (dolist (base (list nil 2 2.0 2d0 10 10.0 10d0 (ash 1 99) (ash 1 3000) 8/7 (/ (ash 1 3000) 7))) (dolist (number (list 100 100.0 100d0