Skip to content
Commits on Source (81)
Expand all Hide whitespace changes
Inline Side-by-side
BUILDING
View file @ 583140fc
......@@ -334,6 +334,18 @@ including CLX, CMUCL/Motif, the Motif debugger, inspector, and control
panel, and the Hemlock editor. It will use the lisp executable and
core of the given target.
Note: To build with Motif (clm), you need to have the Motif libraries
available and headers available to build motifd, the clm Motif server.
OpenMotif is known to work.
You may need to adjust the include paths and library paths in
src/motif/server/Config.* to match where Motif is installed if the
paths therein are incorrect.
Unless you intend to use clm and motifd, you can safely ignore the
build failure. Everything else will have been compiled correctly; you
just can't use clm.
* bin/make-dist.sh [-bg] [-G group] [-O owner] target-directory version arch os
This script creates both main and extra distribution tarballs from the
......
README.md
View file @ 583140fc
......@@ -8,3 +8,45 @@ debugger and code profiler; and an Emacs-like editor implemented in
Common Lisp. CMUCL is maintained by a team of volunteers collaborating
over the Internet, and is mostly in the public domain.
Here is a summary of its main features:
* support for **static arrays** that are never moved by GC but are
properly removed when no longer referenced.
* **Unicode** support, including many of the most common external
formats such as UTF-8 and support for handling Unix, DOS, and
Mac end-of-line schemes.
* native **double-double floats** including complex double-double
floats and specialized arrays for double-double floats and and
complex double-double floats that give approximately 106 bits
(32 digits) of precision.
* a **sophisticated native-code compiler** which is capable of
powerful type inferences, and generates code competitive in
speed with C compilers.
* **generational garbage collection** on all supported
architectures.
* **multiprocessing capability** on the x86 ports.
* a foreign function interface which allows interfacing with C code
and system libraries, including shared libraries on most platforms,
and direct access to Unix system calls.
* support for interprocess communication and remote procedure calls.
* an implementation of CLOS, the [Common Lisp Object
System](http://en.wikipedia.org/wiki/Common_Lisp_Object_System),
which includes multimethods and a metaobject protocol.
* a graphical source-level debugger using a Motif interface, and a
code profiler.
* an interface to the X11 Window System (CLX), and a sophisticated
graphical widget library ([Garnet](https://www.cs.cmu.edu/~garnet/),
available separately).
* programmer-extensible input and output streams ([Gray
Streams](http://www.nhplace.com/kent/CL/Issues/stream-definition-by-user.html)
and
[simple-streams](http://www.franz.com/support/documentation/current/doc/streams.htm)).
* an Emacs-like editor,
[Hemlock](http://cmucl.org/hemlock/index.html), implemented in
Common Lisp.
* **freely redistributable**: free, with full source code (most of
which is in the public domain) and no strings attached (and no
warranty). Like the GNU/Linux and *BSD operating systems, CMUCL is
maintained and improved by a team of volunteers collaborating over
the Internet.
bin/run-tests.sh 0 → 100755
View file @ 583140fc
#! /bin/bash
# Run the testsuite.
#
# By default, all the tests are run, but if additional args are given,
# then just those tests are run.
usage() {
echo "run-tests.sh [?] [-l lisp] [tests]"
echo " -l lisp Lisp to use for the tests; defaults to lisp"
echo " -? This help message"
echo ""
echo "Run the test suite"
echo ""
echo "Any remaining args are the names of the tests to run."
echo "These are basically the file names (without extension)"
echo "in the tests/ directory."
echo ""
echo "This script expects to be run from the top level of the"
echo "cmucl source tree. That is, is should be invoked as"
echo "bin/run-tests.sh"
exit 0;
}
LISP=lisp
while getopts "h?l:" arg
do
case $arg in
l) LISP=$OPTARG ;;
\?) usage ;;
esac
done
# Shift out the options
shift $[$OPTIND - 1]
if [ $# -eq 0 ]; then
# No args so run all the tests
$LISP -noinit -load tests/run-tests.lisp -eval '(cmucl-test-runner:run-all-tests)'
else
# Run selected files. Convert each file name to uppercase and append "-TESTS"
result=""
for f in $*
do
new=`echo $f | tr '[a-z]' '[A-Z]'`
result="$result "\"$new-TESTS\"
done
$LISP -noinit -load tests/run-tests.lisp -eval "(progn (cmucl-test-runner:load-test-files) (cmucl-test-runner:run-test $result))"
fi
src/code/commandline.lisp
View file @ 583140fc
......@@ -283,8 +283,9 @@
(defswitch "dynamic-space-size" nil
"Specifies the number of megabytes that should be allocated to the
heap. If not specified, a platform-specific default is used. The
actual maximum allowed heap size is platform-specific."
heap. If not specified, a platform-specific default is used. If 0,
the platform-specific maximum heap size is used. The actual maximum
allowed heap size is platform-specific."
"megabytes")
(defswitch "read-only-space-size" nil
......
src/code/error.lisp
View file @ 583140fc
......@@ -1138,9 +1138,14 @@
(format stream (intl:gettext "Arithmetic error ~S signalled.")
(type-of condition))
(when (arithmetic-error-operation condition)
(format stream (intl:gettext "~%Operation was ~S, operands ~S.")
(arithmetic-error-operation condition)
(arithmetic-error-operands condition))))))
;; Printing the operands can signal these FP traps, so
;; disable them while we're printing out the error
;; message.
(with-float-traps-masked (:overflow :underflow :inexact
#+x86 :denormalized-operand)
(format stream (intl:gettext "~%Operation was ~S, operands ~S.")
(arithmetic-error-operation condition)
(arithmetic-error-operands condition)))))))
(define-condition division-by-zero (arithmetic-error) ())
(define-condition floating-point-overflow (arithmetic-error) ())
......
src/code/exports.lisp
View file @ 583140fc
......@@ -1579,11 +1579,15 @@
"DOUBLE-FLOAT-POSITIVE-INFINITY" "LONG-FLOAT-POSITIVE-INFINITY"
"SINGLE-FLOAT-NEGATIVE-INFINITY" "SHORT-FLOAT-NEGATIVE-INFINITY"
"DOUBLE-FLOAT-NEGATIVE-INFINITY" "LONG-FLOAT-NEGATIVE-INFINITY"
"GET-FLOATING-POINT-MODES" "SET-FLOATING-POINT-MODES"
"GET-FLOATING-POINT-MODES"
"SET-FLOATING-POINT-MODES"
"ENCODE-FLOATING-POINT-MODES"
"DECODE-FLOATING-POINT-MODES"
"FLOAT-DENORMALIZED-P" "FLOAT-INFINITY-P"
"FLOAT-NAN-P" "FLOAT-TRAPPING-NAN-P"
"FLOAT-SIGNALING-NAN-P"
"WITH-FLOAT-TRAPS-MASKED")
"WITH-FLOAT-TRAPS-MASKED"
"WITH-FLOAT-TRAPS-ENABLED")
;; More float extensions
#+double-double
(:export "LEAST-POSITIVE-NORMALIZED-DOUBLE-DOUBLE-FLOAT"
......
src/code/extfmts.lisp
View file @ 583140fc
......@@ -1133,9 +1133,12 @@ character and illegal outputs are replaced by a question mark.")
The standard streams are sys::*stdin*, sys::*stdout*, and
sys::*stderr*, which are normally the input and/or output streams
for *standard-input* and *standard-output*. Also sets sys::*tty*
(normally *terminal-io* to the given external format. If the
optional argument Filenames is gvien, then the filename encoding is
set to the specified format."
(normally *terminal-io* to the given external format. The value of
*default-external-format* is not changed.
If the optional argument Filenames is given, then the filename
encoding is set to the specified format, if it has not already been
specified previously."
(unless (find-external-format terminal)
(error (intl:gettext "Can't find external-format ~S.") terminal))
(setf (stream-external-format sys:*stdin*) terminal
......
src/code/float-trap.lisp
View file @ 583140fc
......@@ -22,8 +22,12 @@
(export '(current-float-trap floating-point-modes sigfpe-handler))
)
(in-package "EXTENSIONS")
(export '(set-floating-point-modes get-floating-point-modes
with-float-traps-masked))
(export '(set-floating-point-modes
get-floating-point-modes
decode-floating-point-modes
encode-floating-point-modes
with-float-traps-masked
with-float-traps-enabled))
(in-package "VM")
(eval-when (compile load eval)
......@@ -103,7 +107,7 @@
final-mode))
(defun (setf floating-point-modes) (new-mode)
(declare (type (unsigned-byte 24) new-mode))
(declare (type (unsigned-byte 32) new-mode))
;; Set the floating point modes for both X87 and SSE2. This
;; include the rounding control bits.
(let* ((rc (ldb float-rounding-mode new-mode))
......@@ -116,8 +120,8 @@
;; is ok and would be the correct setting if we
;; ever support long-floats.
(ash 3 8))))
(setf (vm::sse2-floating-point-modes) new-mode)
(setf (vm::x87-floating-point-modes) x87-modes))
(setf (vm::sse2-floating-point-modes) (ldb (byte 24 0) new-mode))
(setf (vm::x87-floating-point-modes) (ldb (byte 24 0) x87-modes)))
new-mode)
)
......@@ -134,16 +138,18 @@
new-mode)
)
;;; SET-FLOATING-POINT-MODES -- Public
;;; %SET-FLOATING-POINT-MODES -- Public
;;;
(defun set-floating-point-modes (&key (traps nil traps-p)
(rounding-mode nil round-p)
(current-exceptions nil current-x-p)
(accrued-exceptions nil accrued-x-p)
(fast-mode nil fast-mode-p))
"This function sets options controlling the floating-point hardware. If a
keyword is not supplied, then the current value is preserved. Possible
keywords:
(defun encode-floating-point-modes (&key (floating-point-modes (floating-point-modes))
(traps nil traps-p)
(rounding-mode nil round-p)
(current-exceptions nil current-x-p)
(accrued-exceptions nil accrued-x-p)
(fast-mode nil fast-mode-p))
"Encode the floating-point modes according to the give options and the
specified mode, Floating-Point-Modes. The resulting new mode is
returned. If a keyword is not supplied, then the current value is
preserved. Possible keywords:
:TRAPS
A list of the exception conditions that should cause traps. Possible
......@@ -168,7 +174,7 @@
GET-FLOATING-POINT-MODES may be used to find the floating point modes
currently in effect."
(let ((modes (floating-point-modes)))
(let ((modes floating-point-modes))
(when traps-p
(let ((trap-mask-bits (float-trap-mask traps)))
(setf (ldb float-traps-byte modes) trap-mask-bits)
......@@ -214,20 +220,56 @@
(setq modes (logior float-fast-bit modes))
(setq modes (logand (lognot float-fast-bit) modes))))
(setf (floating-point-modes) modes))
modes))
;;; SET-FLOATING-POINT-MODES -- Public
;;;
(defun set-floating-point-modes (&rest args
&key traps
rounding-mode
current-exceptions
accrued-exceptions
fast-mode)
"This function sets options controlling the floating-point hardware. If a
keyword is not supplied, then the current value is preserved. Possible
keywords:
:TRAPS
A list of the exception conditions that should cause traps. Possible
exceptions are :UNDERFLOW, :OVERFLOW, :INEXACT, :INVALID,
:DIVIDE-BY-ZERO, and on the X86 :DENORMALIZED-OPERAND. Initially
all traps except :INEXACT are enabled.
:ROUNDING-MODE
The rounding mode to use when the result is not exact. Possible values
are :NEAREST, :POSITIVE-INFINITY, :NEGATIVE-INFINITY and :ZERO.
Initially, the rounding mode is :NEAREST.
:CURRENT-EXCEPTIONS
:ACCRUED-EXCEPTIONS
These arguments allow setting of the exception flags. The main use is
setting the accrued exceptions to NIL to clear them.
:FAST-MODE
Set the hardware's \"fast mode\" flag, if any. When set, IEEE
conformance or debuggability may be impaired. Some machines may not
have this feature, in which case the value is always NIL.
GET-FLOATING-POINT-MODES may be used to find the floating point modes
currently in effect."
(declare (ignorable traps rounding-mode current-exceptions accrued-exceptions fast-mode))
(setf (floating-point-modes)
(apply #'encode-floating-point-modes args))
(values))
;;; GET-FLOATING-POINT-MODES -- Public
;;; %GET-FLOATING-POINT-MODES -- Public
;;;
(defun get-floating-point-modes ()
(defun decode-floating-point-modes (modes)
"This function returns a list representing the state of the floating point
modes. The list is in the same format as the keyword arguments to
SET-FLOATING-POINT-MODES, i.e.
(apply #'set-floating-point-modes (get-floating-point-modes))
sets the floating point modes to their current values (and thus is a no-op)."
modes given in Modes. The list is in the same format as the keyword arguments to
SET-FLOATING-POINT-MODES."
(flet ((exc-keys (bits)
(macrolet ((frob ()
`(collect ((res))
......@@ -237,13 +279,23 @@
float-trap-alist)
(res))))
(frob))))
(let ((modes (floating-point-modes)))
`(:traps ,(exc-keys (ldb float-traps-byte modes))
:rounding-mode ,(car (rassoc (ldb float-rounding-mode modes)
rounding-mode-alist))
:current-exceptions ,(exc-keys (ldb float-exceptions-byte modes))
:accrued-exceptions ,(exc-keys (ldb float-sticky-bits modes))
:fast-mode ,(logtest float-fast-bit modes)))))
`(:traps ,(exc-keys (ldb float-traps-byte modes))
:rounding-mode ,(car (rassoc (ldb float-rounding-mode modes)
rounding-mode-alist))
:current-exceptions ,(exc-keys (ldb float-exceptions-byte modes))
:accrued-exceptions ,(exc-keys (ldb float-sticky-bits modes))
:fast-mode ,(logtest float-fast-bit modes))))
;;; GET-FLOATING-POINT-MODES -- Public
;;;
(defun get-floating-point-modes ()
"This function returns a list representing the state of the floating point
modes. The list is in the same format as the keyword arguments to
SET-FLOATING-POINT-MODES, i.e.
(apply #'set-floating-point-modes (get-floating-point-modes))
sets the floating point modes to their current values (and thus is a no-op)."
(decode-floating-point-modes (floating-point-modes)))
;;; CURRENT-FLOAT-TRAP -- Interface
......@@ -267,142 +319,181 @@
(alien:sap-alien scp (* unix:sigcontext))))
(traps (logand (ldb float-exceptions-byte modes)
(ldb float-traps-byte modes))))
#+(and darwin ppc)
(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
;; enabled? If we did that then the accrued exceptions would be
;; correct.
(setf (ldb float-sticky-bits new-modes) 0)
;; Clear out the various sticky invalid operation bits too.
;;
;; 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)))
new-modes))
#+sse2
(let* ((new-modes modes)
(new-exceptions (logandc2 (ldb float-exceptions-byte new-modes)
traps)))
;; Clear out the status for any enabled traps. With SSE2, if
;; the current exception is enabled, the next FP instruction
;; will cause the exception to be signaled again. Hence, we
;; need to clear out the exceptions that we are handling here.
(setf (ldb float-exceptions-byte new-modes) new-exceptions)
;; XXX: This seems not right. Shouldn't we be setting the modes
;; in the sigcontext instead? This however seems to do what we
;; want.
(setf (vm:floating-point-modes) new-modes))
(multiple-value-bind (fop operands)
(let ((sym (find-symbol "GET-FP-OPERANDS" "VM")))
(if (fboundp sym)
(funcall sym (alien:sap-alien scp (* unix:sigcontext)) modes)
(values nil nil)))
(cond ((not (zerop (logand float-divide-by-zero-trap-bit traps)))
(error 'division-by-zero
:operation fop
:operands operands))
((not (zerop (logand float-invalid-trap-bit traps)))
(error 'floating-point-invalid-operation
:operation fop
:operands operands))
((not (zerop (logand float-overflow-trap-bit traps)))
(error 'floating-point-overflow
:operation fop
:operands operands))
((not (zerop (logand float-underflow-trap-bit traps)))
(error 'floating-point-underflow
:operation fop
:operands operands))
((not (zerop (logand float-inexact-trap-bit traps)))
(error 'floating-point-inexact
:operation fop
:operands operands))
#+x86
((not (zerop (logand float-denormal-trap-bit traps)))
(error 'floating-point-denormal-operand
:operation fop
:operands operands))
(t
;; It looks like the sigcontext on Solaris/x86 doesn't
;; actually save the status word of the FPU. The
;; operands also seem to be missing. Signal a general
;; arithmetic error.
#+(and x86 solaris)
(error _"SIGFPE with no exceptions currently enabled? (si-code = ~D)"
code)
;; For all other x86 ports, we should only get here if
;; the SIGFPE was caused by an integer overflow on
;; division. For sparc and ppc, I (rtoy) don't think
;; there's any other way to get here since integer
;; overflows aren't signaled.
;;
;; In that case, FOP should be /, so we can generate a
;; nice arithmetic-error. It's possible to use CODE,
;; which is supposed to indicate what caused the
;; exception, but each OS is different, so we don't; FOP
;; can tell us.
#-(and x86 solaris)
(if fop
(error 'arithmetic-error
:operation fop
:operands operands)
(error _"SIGFPE with no exceptions currently enabled? (si-code = ~D)"
code)))))))
;;; WITH-FLOAT-TRAPS-MASKED -- Public
;;;
(defmacro with-float-traps-masked (traps &body body)
"Execute BODY with the floating point exceptions listed in TRAPS
;; Don't let throws get away without resetting the
;; floating-point modes back to the original values which we get
;; from the sigcontext. Because we can throw, we never return
;; from the signal handler so the sigcontext is never restored.
;; This means we need to restore the fpu state ourselves.
(unwind-protect
(cond ((not (zerop (logand float-divide-by-zero-trap-bit traps)))
(error 'division-by-zero
:operation fop
:operands operands))
((not (zerop (logand float-invalid-trap-bit traps)))
(error 'floating-point-invalid-operation
:operation fop
:operands operands))
((not (zerop (logand float-overflow-trap-bit traps)))
(error 'floating-point-overflow
:operation fop
:operands operands))
((not (zerop (logand float-underflow-trap-bit traps)))
(error 'floating-point-underflow
:operation fop
:operands operands))
((not (zerop (logand float-inexact-trap-bit traps)))
(error 'floating-point-inexact
:operation fop
:operands operands))
#+x86
((not (zerop (logand float-denormal-trap-bit traps)))
(error 'floating-point-denormal-operand
:operation fop
:operands operands))
(t
;; It looks like the sigcontext on Solaris/x86 doesn't
;; actually save the status word of the FPU. The
;; operands also seem to be missing. Signal a general
;; arithmetic error.
#+(and x86 solaris)
(error _"SIGFPE with no exceptions currently enabled? (si-code = ~D)"
code)
;; For all other x86 ports, we should only get here if
;; the SIGFPE was caused by an integer overflow on
;; division. For sparc and ppc, I (rtoy) don't think
;; there's any other way to get here since integer
;; overflows aren't signaled.
;;
;; In that case, FOP should be /, so we can generate a
;; nice arithmetic-error. It's possible to use CODE,
;; which is supposed to indicate what caused the
;; exception, but each OS is different, so we don't; FOP
;; can tell us.
#-(and x86 solaris)
(if fop
(error 'arithmetic-error
:operation fop
:operands operands)
(error _"SIGFPE with no exceptions currently enabled? (si-code = ~D)"
code))))
;; Cleanup
(let* ((new-modes modes)
(new-exceptions (logandc2 (ldb float-exceptions-byte new-modes)
traps)))
#+(and darwin ppc)
(progn
;; (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.
;;
;; XXX: Should we just clear out the bits for the traps that are
;; enabled? If we did that then the accrued exceptions would be
;; correct.
(setf (ldb float-sticky-bits new-modes) 0)
;; Clear out the various sticky invalid operation bits too.
;;
;; 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))
#+sse2
(progn
;; Clear out the status for any enabled traps. With SSE2, if
;; the current exception is enabled, the next FP instruction
;; will cause the exception to be signaled again. Hence, we
;; need to clear out the exceptions that we are handling here.
(setf (ldb float-exceptions-byte new-modes) new-exceptions)
#+nil
(progn
(format *debug-io* "sigcontext modes: #x~4x (~A)~%"
modes (decode-floating-point-modes modes))
(format *debug-io* "current modes: #x~4x (~A)~%"
(vm:floating-point-modes) (get-floating-point-modes))
(format *debug-io* "new modes: #x~x (~A)~%"
new-modes (decode-floating-point-modes new-modes)))
(setf (vm:floating-point-modes) new-modes))
#-(or sse2 (and darwin ppc))
(progn
;; Apparently nothing needed for sparc it seems The FPU
;; state in the signal handler is unchanged and it seems we
;; don't need to reset it any way when we throw out.
))))))
(macrolet
((with-float-traps (name merge-traps docstring)
;; Define macros to enable or disable floating-point
;; exceptions. Masked exceptions and enabled exceptions only
;; differ whether we AND in the bits or OR them, respectively.
;; MERGE-TRAPS is the logical operation to merge the traps with
;; the current floating-point mode. Thus, use and MERGE-EXCEPTIONS is the
;; logical operation to merge the exceptions (sticky bits) with
;; the current mode.
(let ((macro-name (symbolicate "WITH-FLOAT-TRAPS-" name)))
`(progn
(defmacro ,macro-name (traps &body body)
,docstring
(let ((traps (dpb (float-trap-mask traps) float-traps-byte 0))
(exceptions (dpb (float-trap-mask traps) float-sticky-bits 0))
(trap-mask (dpb (lognot (float-trap-mask traps))
float-traps-byte #xffffffff))
(exception-mask (dpb (lognot (vm::float-trap-mask traps))
float-sticky-bits #xffffffff))
;; On ppc if we are masking the invalid trap, we need to make
;; sure we wipe out the various individual sticky bits
;; representing the invalid operation. Otherwise, if we
;; enable the invalid trap later, these sticky bits will cause
;; an exception.
;;
;; FIXME: Consider removing these for ppc. Since
;; we now restore the original modes exactly, I
;; don't think these are needed anymore.
#+ppc
(invalid-mask (if (member :invalid traps)
(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)))
(unwind-protect
(progn
(setf (floating-point-modes)
(ldb (byte 32 0)
(logand (,',merge-traps ,orig-modes ,trap-mask)
,exception-mask)))
,@body)
;; Restore the modes exactly as they were.
(setf (floating-point-modes) ,orig-modes)))))))))
;; WITH-FLOAT-TRAPS-MASKED -- Public
(with-float-traps masked logand
_N"Execute BODY with the floating point exceptions listed in TRAPS
masked (disabled). TRAPS should be a list of possible exceptions
which includes :UNDERFLOW, :OVERFLOW, :INEXACT, :INVALID and
:DIVIDE-BY-ZERO and on the X86 :DENORMALIZED-OPERAND. The respective
accrued exceptions are cleared at the start of the body to support
their testing within, and restored on exit."
(let ((traps (dpb (float-trap-mask traps) float-traps-byte 0))
(exceptions (dpb (float-trap-mask traps) float-sticky-bits 0))
(trap-mask (dpb (lognot (float-trap-mask traps))
float-traps-byte #xffffffff))
(exception-mask (dpb (lognot (vm::float-trap-mask traps))
float-sticky-bits #xffffffff))
;; On ppc if we are masking the invalid trap, we need to make
;; sure we wipe out the various individual sticky bits
;; representing the invalid operation. Otherwise, if we
;; enable the invalid trap later, these sticky bits will cause
;; an exception.
#+ppc
(invalid-mask (if (member :invalid traps)
(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)))
(unwind-protect
(progn
(setf (floating-point-modes)
(logand ,orig-modes ,(logand trap-mask exception-mask)))
,@body)
;; Restore the original traps and exceptions.
(setf (floating-point-modes)
(logior (logand ,orig-modes ,(logior traps exceptions))
(logand (floating-point-modes)
,(logand trap-mask exception-mask)
#+ppc
,invalid-mask
#+mips ,(dpb 0 float-exceptions-byte #xffffffff))))))))
their testing within, and restored on exit.")
;; WITH-FLOAT-TRAPS-ENABLED -- Public
(with-float-traps enabled logorc2
_N"Execute BODY with the floating point exceptions listed in TRAPS
enabled. TRAPS should be a list of possible exceptions which
includes :UNDERFLOW, :OVERFLOW, :INEXACT, :INVALID and
:DIVIDE-BY-ZERO and on the X86 :DENORMALIZED-OPERAND. The respective
accrued exceptions are cleared at the start of the body to support
their testing within, and restored on exit."))
src/code/irrat.lisp
View file @ 583140fc
......@@ -252,6 +252,13 @@
(return-from intexp base))
(when (eql base -1)
(return-from intexp (if (oddp power) -1 1)))
;; Handle 0 raised to a power. Return 0 if the power is
;; non-negative or signal a divide-by-zero if the power is negative.
(when (zerop base)
(if (minusp power)
(error 'division-by-zero)
(return-from intexp base)))
(when (> (abs power) *intexp-maximum-exponent*)
;; Allow user the option to continue with calculation, possibly
......
src/code/pathname.lisp
View file @ 583140fc
......@@ -1227,18 +1227,21 @@ a host-structure or string."
;; Not path-designator because a file-stream can't have a
;; wild pathname.
(type (or string pathname) in-wildname))
(with-pathname (pathname in-pathname)
(with-pathname (wildname in-wildname)
(macrolet ((frob (field &optional (op 'components-match ))
`(or (null (,field wildname))
(,op (,field pathname) (,field wildname)))))
(and (or (null (%pathname-host wildname))
(eq (%pathname-host wildname) (%pathname-host pathname)))
(frob %pathname-device)
(frob %pathname-directory directory-components-match)
(frob %pathname-name)
(frob %pathname-type)
(frob %pathname-version))))))
(with-pathname (in-path in-pathname)
(enumerate-search-list (pathname in-path)
(with-pathname (in-wild in-wildname)
(enumerate-search-list (wildname in-wild)
(macrolet ((frob (field &optional (op 'components-match ))
`(or (null (,field wildname))
(,op (,field pathname) (,field wildname)))))
(when (and (or (null (%pathname-host wildname))
(eq (%pathname-host wildname) (%pathname-host pathname)))
(frob %pathname-device)
(frob %pathname-directory directory-components-match)
(frob %pathname-name)
(frob %pathname-type)
(frob %pathname-version))
(return-from pathname-match-p pathname))))))))
;;; SUBSTITUTE-INTO -- Internal
......
src/code/run-program.lisp
View file @ 583140fc
......@@ -471,8 +471,9 @@
The keyword arguments have the following meanings:
:env -
An A-LIST mapping keyword environment variables to simple-string
values.
An A-LIST mapping keyword environment variables to
simple-string values. This is the shell environment for
Program. Defaults to *environment-list*.
:wait -
If non-NIL (default), wait until the created process finishes. If
NIL, continue running Lisp until the program finishes.
......
src/code/save.lisp
View file @ 583140fc
......@@ -36,7 +36,8 @@
might not be.")
(defvar *environment-list* nil
"An alist mapping environment variables (as keywords) to either values")
"An alist mapping each environment variable (as a keyword) to its
value.")
(defvar *environment-list-initialized* nil
"Non-NIL if environment-init has been called")
......
src/compiler/generic/vm-fndb.lisp
View file @ 583140fc
......@@ -288,6 +288,13 @@
(bignum-element-type (mod #+amd64 64 #-amd64 32)) bignum-element-type
(foldable flushable movable))
#+x86
(defknown (bignum::%shld bignum::%shrd)
(bignum-element-type bignum-element-type (unsigned-byte 5))
bignum-element-type
(foldable flushable movable))
;;;; Bit-bashing routines.
......
src/compiler/x86/arith.lisp
View file @ 583140fc
......@@ -1579,6 +1579,7 @@
(inst mov tmp y)
(inst shr tmp 18)
(inst xor y tmp)))
;;; Modular arithmetic
;;; logical operations
......
src/compiler/x86/float-sse2.lisp
View file @ 583140fc
......@@ -1181,19 +1181,17 @@
(:args (hi-bits :scs (signed-reg))
(lo-bits :scs (unsigned-reg)))
(:results (res :scs (double-reg)))
(:temporary (:sc double-stack) temp)
(:arg-types signed-num unsigned-num)
(:result-types double-float)
(:translate make-double-float)
(:temporary (:sc double-reg) temp)
(:policy :fast-safe)
(:vop-var vop)
(:generator 2
(let ((offset (1+ (tn-offset temp))))
(storew hi-bits ebp-tn (- offset))
(storew lo-bits ebp-tn (- (1+ offset)))
(inst movsd res (make-ea :dword :base ebp-tn
:disp (- (* (1+ offset) word-bytes)))))))
(:generator 4
(inst movd temp hi-bits)
(inst psllq temp 32)
(inst movd res lo-bits)
(inst orpd res temp)))
(define-vop (single-float-bits)
(:args (float :scs (single-reg descriptor-reg)
......
src/compiler/x86/float.lisp
View file @ 583140fc
......@@ -2340,6 +2340,13 @@
;;
;; When one of the mask bits (0-5) is set, then that exception is
;; masked so that no exception is generated.
;;
;; Returns the control and status words merged into one. The low 16
;; bits contains the control word with the exception mask bits
;; inverted to indicate exception enable bits. The high 16 bits
;; contains the status word, but the top 8 bits of the status word are
;; cleared, effectively removing the condition code, top-of-stack
;; bits, and the FPU busy bit.
(define-vop (x87-floating-point-modes)
(:results (res :scs (unsigned-reg)))
(:result-types unsigned-num)
......
src/compiler/x86/insts.lisp
View file @ 583140fc
......@@ -859,6 +859,18 @@
;; optional fields
(imm))
;; Double shift instructions. Like ext-reg-reg/mem but there's no
;; width field.
(disassem:define-instruction-format (ext-reg-reg/mem-shift 24)
(prefix :field (byte 8 0) :value #b00001111)
(op :field (byte 8 8))
(reg/mem :fields (list (byte 2 22) (byte 3 16))
:type 'reg/mem)
(reg :field (byte 3 19) :type 'reg)
;; optional fields
(imm))
;;; ----------------------------------------------------------------
;;; this section added by jrd, for fp instructions.
......@@ -1535,24 +1547,22 @@
(defun emit-double-shift (segment opcode dst src amt)
(let ((size (matching-operand-size dst src)))
(when (eq size :byte)
(error "Double shifts can only be used with words."))
(error "Double shifts cannot be used with byte registers."))
(maybe-emit-operand-size-prefix segment size)
(emit-byte segment #b00001111)
(emit-byte segment (dpb opcode (byte 1 3)
(if (eq amt :cl) #b10100101 #b10100100)))
#+nil
(emit-ea segment dst src)
(emit-ea segment dst (reg-tn-encoding src)) ; pw tries this
(emit-ea segment dst (reg-tn-encoding src))
(unless (eq amt :cl)
(emit-byte segment amt))))
(eval-when (compile eval)
(defun double-shift-inst-printer-list (op)
`(#+nil
(ext-reg-reg/mem-imm ((op ,(logior op #b100))
(imm nil :type signed-imm-byte)))
(ext-reg-reg/mem ((op ,(logior op #b101)))
(:name :tab reg/mem ", " 'cl)))))
`((ext-reg-reg/mem-shift ((op ,(logior op #b100))
(imm nil :type signed-imm-byte))
(:name :tab reg/mem ", " reg ", " imm))
(ext-reg-reg/mem-shift ((op ,(logior op #b101)))
(:name :tab reg/mem ", " reg ", " 'cl)))))
(define-instruction shld (segment dst src amt)
(:declare (type (or (member :cl) (mod 32)) amt))
......@@ -3136,6 +3146,8 @@
;; logical
(define-regular-sse-inst andpd #x66 #x54 t)
(define-regular-sse-inst andps nil #x54)
(define-regular-sse-inst orpd #x66 #x56 t)
(define-regular-sse-inst orps nil #x56)
(define-regular-sse-inst xorpd #x66 #x57 t)
(define-regular-sse-inst xorps nil #x57)
;; comparison
......
src/contrib/asdf/asdf.lisp
View file @ 583140fc
This diff is collapsed.
src/contrib/asdf/doc/asdf.html
View file @ 583140fc
This diff is collapsed.
src/contrib/asdf/doc/asdf.info
View file @ 583140fc
This diff is collapsed.