Commit 5e075fa0 authored by Raymond Toy's avatar Raymond Toy

Merge branch 'master' into rtoy-update-clx-with-cmucl-fixes

parents 6c18cc63 d9487768
Pipeline #672 passed with stage
in 18 minutes
variables:
download_url: "https://common-lisp.net/project/cmucl/downloads/snapshots/2018/01"
version: "2018-01-x86"
download_url: "https://common-lisp.net/project/cmucl/downloads/snapshots/2018/10"
version: "2018-10-x86"
bootstrap: "-B boot-21d.lisp"
linux-runner:
image: ubuntu:16.04
tags:
- linux
before_script:
......@@ -12,7 +14,7 @@ linux-runner:
- mkdir snapshot
- (cd snapshot; tar xjf ../cmucl-$version-linux.tar.bz2; tar xjf ../cmucl-$version-linux.extra.tar.bz2)
script:
- bin/build.sh -C "" -o snapshot/bin/lisp
- bin/build.sh $bootstrap -C "" -o snapshot/bin/lisp
- bin/make-dist.sh -I dist linux-4
- bin/run-tests.sh -l dist/bin/lisp 2>&1 | tee test.log
......@@ -24,6 +26,6 @@ osx-runner:
- mkdir snapshot
- (cd snapshot; tar xjf ../cmucl-$version-darwin.tar.bz2)
script:
- bin/build.sh -C "" -o snapshot/bin/lisp
- bin/build.sh $bootstrap -C "" -o snapshot/bin/lisp
- bin/make-dist.sh -I dist darwin-4
- bin/run-tests.sh -l dist/bin/lisp 2>&1 | tee test.log
**Describe the bug**
A clear and concise description of what the bug is.
**To Reproduce**
Steps to reproduce the behavior:
1. Go to '...'
2. Click on '....'
3. Scroll down to '....'
4. See error
**Expected behavior**
A clear and concise description of what you expected to happen.
**Screenshots**
If applicable, add screenshots to help explain your problem.
**Desktop (please complete the following information):**
- OS: [e.g. Linux]
- Version [e.g. 21c]
**Additional context**
Add any other context about the problem here.
/label ~bug
**Describe the feature**
Briefly describe the feature you would like see.
**Is there a prototype?**
If you have a prototype, provide links to illustrate this addition. This is the best way to propose a new feature.
**Describe the feature in more detail**
Provide more information to describe the feature.
/label ~feature
This diff is collapsed.
......@@ -144,12 +144,11 @@ buildit ()
fi
$TOOLDIR/load-world.sh $TARGET "$VERSION" || { echo "Failed: $TOOLDIR/load-world.sh"; exit 1; }
$TARGET/lisp/lisp -batch -noinit -nositeinit $FPU_MODE < /dev/null || { echo "Failed: $TARGET/lisp/lisp -batch -noinit $FPU_MODE"; exit 1; }
$TARGET/lisp/lisp -batch -noinit -nositeinit < /dev/null || { echo "Failed: $TARGET/lisp/lisp -batch -noinit"; exit 1; }
return 0;
fi
}
FPU_MODE=
BUILDWORLD="$TOOLDIR/build-world.sh"
BUILD_POT="yes"
UPDATE_TRANS=
......
......@@ -83,7 +83,7 @@ case $uname_s in
hp700*) motif_variant=hpux_cc ;;
pmax_mach) motif_variant=pmax_mach ;;
sgi*) motif_variant=irix ;;
x86_linux|linux*) motif_variant=x86 ;;
x86_linux*|linux*) motif_variant=x86 ;;
esac
}
[ -f src/motif/server/Config.$motif_variant ] || quit "No such motif-variant could be found: Config.$motif_variant"
......
......@@ -34,12 +34,19 @@ done
# Shift out the options
shift $[$OPTIND - 1]
# Create the test directory needed issue.45 test.
# Create the test directory needed by the issue.45 test.
rm -rf test-tmp
mkdir test-tmp
ln -s /bin/ls test-tmp/ls-link
# Cleanup temp files and directories that we created during testing.
function cleanup {
rm -f /tmp/trac.36.bom.txt /tmp/trac.43.txt
rm -rf /tmp/foo
}
trap cleanup EXIT
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)'
......
;; Get rid of incorrect symbol c::%unary-fround and just inherit
;; %unary-fround from the kernel package.
(ext:without-package-locks
(unintern 'c::%unary-fround "C"))
(export 'kernel::%unary-fround "KERNEL")
;;;;
;;;; Boot file for changing the fasl file version numbers to 21d.
;;;;
(in-package :c)
(setf lisp::*enable-package-locked-errors* nil)
;;;
;;; Note that BYTE-FASL-FILE-VERSION is a constant.
;;;
;;; (Be sure to change BYTE-FASL-FILE-VERSION in
;;; compiler/byte-comp.lisp to the correct value too!)
;;;
#-cmu21d
(setf (symbol-value 'byte-fasl-file-version) #x21d)
#-cmu21d
(setf (backend-fasl-file-version *target-backend*) #x21d)
;;;
;;; Don't check fasl versions in the compiling Lisp because we'll
;;; load files compiled with the new version numbers.
;;;
#-cmu21d
(setq lisp::*skip-fasl-file-version-check* t)
;;;
;;; This is here because BYTE-FASL-FILE-VERSION is constant-folded in
;;; OPEN-FASL-FILE. To make the new version number take effect, we
;;; have to redefine the function.
;;;
#-cmu21d
(defun open-fasl-file (name where &optional byte-p)
(declare (type pathname name))
(let* ((stream (open name :direction :output
:if-exists :new-version
:element-type '(unsigned-byte 8)
:class 'binary-text-stream))
(res (make-fasl-file :stream stream)))
(multiple-value-bind
(version f-vers f-imp)
(if byte-p
(values "Byte code"
byte-fasl-file-version
(backend-byte-fasl-file-implementation *backend*))
(values (backend-version *backend*)
(backend-fasl-file-version *backend*)
(backend-fasl-file-implementation *backend*)))
(format stream
"FASL FILE output from ~A.~@
Compiled ~A on ~A~@
Compiler ~A, Lisp ~A~@
Targeted for ~A, FASL version ~X~%"
where
(ext:format-universal-time nil (get-universal-time))
(machine-instance) compiler-version
(lisp-implementation-version)
version f-vers)
;;
;; Terminate header.
(dump-byte 255 res)
;;
;; Specify code format.
(dump-fop 'lisp::fop-long-code-format res)
(dump-byte f-imp res)
(dump-unsigned-32 f-vers res))
res))
......@@ -177,4 +177,93 @@
wm-size-hints-user-specified-position-p wm-size-hints-user-specified-size-p
wm-size-hints-width wm-size-hints-width-inc wm-size-hints-win-gravity
wm-size-hints-x wm-size-hints-y wm-zoom-hints write-bitmap-file
write-resources xatom))
write-resources xatom
picture-subwindow-mode picture-format-id
mode-info-hsyncstart
mode-info
xfree86-vidmode-get-mode-line
picture-drawable
picture-alpha-y-origin
make-mode-info
shape-mask
xfree86-vidmode-get-viewport
render-query-version
shape-rectangles
xfree86-vidmode-select-next-mode
xfree86-vidmode-set-gamma
render-composite-glyphs
xfree86-vidmode-get-dotclocks
render-trapezoids
xfree86-vidmode-get-all-mode-lines
mode-info-hskew
picture-format-type
xfree86-vidmode-get-gamma-ramp
render-create-picture
picture-format-blue-byte
shape-query-extents
xfree86-vidmode-validate-mode-line
shape-offset
shape-input-selected-p
mode-info-vsyncend
shape-select-input
screen-saver-get-idle
mode-info-vtotal
picture-format-depth
picture-clip-x-origin
picture-format-alpha-byte
screen-saver-query-info
xfree86-vidmode-set-gamma-ramp
xfree86-vidmode-switch-to-mode
mode-info-vdisplay
xfree86-vidmode-delete-mode-line
xfree86-vidmode-set-viewport
picture-dither
picture-format-colormap
xfree86-vidmode-lock-mode-switch
render-triangles
xfree86-vidmode-add-mode-line
picture-component-alpha
xfree86-vidmode-get-permissions
shape-get-rectangles
shape-query-version
mode-info-hsyncend
mode-info-hdisplay
picture-repeat
picture-graphics-exposures
xfree86-vidmode-query-version
screen-saver-query-version
find-window-picture-format
render-add-glyph-from-picture
mode-info-private
xfree86-vidmode-get-gamma
picture-alpha-map
xfree86-vidmode-mod-mode-line
mode-info-htotal
render-free-picture
picture-poly-mode
picture-format-green-byte
render-free-glyph-set
render-free-glyphs
shape-combine
render-free-glyph
mode-info-flags
render-fill-rectangle
picture-clip-y-origin
mode-info-vsyncstart
mode-info-privsize
picture-poly-edge
render-composite
picture-format-red-byte
render-add-glyph
picture-format-display
render-reference-glyph-set
xfree86-vidmode-get-gamma-ramp-size
find-matching-picture-formats
mode-info-dotclock
xfree86-vidmode-set-client-version
picture-clip-mask
picture-alpha-x-origin
xfree86-vidmode-get-monitor
render-create-glyph-set
xfree86-vidmode-switch-mode
xfree86-vidmode-select-prev-mode))
......@@ -263,7 +263,8 @@
(backq-unparse (car tail) t)))
(push (backq-unparse (car tail)) accum)))
(backq-append
(mapcar #'(lambda (el) (backq-unparse el t))
(mapcar #'(lambda (el)
(car (backq-unparse el t)))
(cdr form)))
(backq-nconc
(mapcar #'(lambda (el) (backq-unparse el :nconc))
......
......@@ -884,7 +884,12 @@ down to individual words.")
(negate-bignum-in-place result))
(%normalize-bignum result (1+ (* 2 n))))))))
(defun classical-multiply-bignums (a b)
;; Bignum multiply using Knuth's algorithm. We keep this around for
;; now so we can compare the new algorithm against this to make sure
;; this are working.
;;
;; TODO: Remove this eventually?
(defun classical-multiply-bignums-knuth (a b)
(declare (type bignum-type a b))
(let* ((a-plusp (%bignum-0-or-plusp a (%bignum-length a)))
(b-plusp (%bignum-0-or-plusp b (%bignum-length b)))
......@@ -916,6 +921,73 @@ down to individual words.")
(when negate-res (negate-bignum-in-place res))
(%normalize-bignum res len-res)))
;; Classical multiplication of bignums using Knuth's algorithm
;; modified to handle signed bignums. Pretend the bignums are
;; actually unsigned, do an unsigned multiply and then correct the
;; result. This is based on the algorithm in Hacker's Delight.
;;
;; Let a[n] and b[n] represent the individual bits of each bignum with
;; M being the number of bits in a and N being the number of bits in
;; b. If these are interpreted as an unsigned number, then we are
;; multiplying numbers
;;
;; (a + 2^M*a[M-1})*(b + 2^N*b[N-1])
;; = a*b + 2^M*u[M-1]*b + 2^N*b[N-1]*a + 2^(M+N)*a[M-1]*b[M-1]
;;
;; To get the desired result, we need to subtract out the term
;; 2^M*u[M-1]*b + 2^N*b[N-1]*a from the product. The last term
;; doesn't need to subtracted because we know the product fits in M+N
;; bits and this term is beyond that.
(defun classical-multiply-bignums (a b)
(declare (type bignum-type a b))
(let* ((len-a (%bignum-length a))
(len-b (%bignum-length b))
(len-res (+ len-a len-b))
(res (%allocate-bignum len-res)))
(declare (type bignum-index len-a len-b len-res))
;; Unsigned multiply
(dotimes (i len-a)
(declare (type bignum-index i))
(let ((carry-digit 0)
(x (%bignum-ref a i))
(k i))
(declare (type bignum-index k)
(type bignum-element-type carry-digit x))
(dotimes (j len-b)
(multiple-value-bind (big-carry res-digit)
(%multiply-and-add x (%bignum-ref b j)
(%bignum-ref res k)
carry-digit)
(declare (type bignum-element-type big-carry res-digit))
(setf (%bignum-ref res k) res-digit)
(setf carry-digit big-carry)
(incf k)))
(setf (%bignum-ref res k) carry-digit)))
(flet ((apply-correction (neg-arg neg-len pos-arg pos-len)
;; Applies the correction by basically subtracting out
;; 2^M*b where M is the length (in bits) of b and b is
;; the positive term in pos-arg. neg-arg is the negative
;; arg.
(let ((borrow 1))
(dotimes (j pos-len)
(declare (type bignum-index j))
(let ((index (+ j neg-len)))
(declare (type bignum-index index))
(multiple-value-bind (d borrow-out)
(%subtract-with-borrow (%bignum-ref res index)
(%bignum-ref pos-arg j)
borrow)
(setf (%bignum-ref res index) d)
(setf borrow borrow-out)))))))
;; Apply corrections if either of the arguments is negative.
(unless (%bignum-0-or-plusp a len-a)
;; A is negative
(apply-correction a len-a b len-b))
(unless (%bignum-0-or-plusp b len-b)
;; B is negative
(apply-correction b len-b a len-a)))
(%normalize-bignum res len-res)))
(defparameter *min-karatsuba-bits* 512
"Use Karatsuba if the bignums have at least this many bits")
......
......@@ -1566,6 +1566,10 @@
"*TRUST-DYNAMIC-EXTENT-DECLARATIONS*"
"INVALID-FASL")
;; gencgc features
#+gencgc
(:export "GET-GC-ASSERTIONS"
"SET-GC-ASSERTIONS")
;; run-program
(:export "RUN-PROGRAM" "PROCESS-ALIVE-P" "PROCESS-CLOSE"
......@@ -2530,7 +2534,8 @@
"SET-SYMBOL-VALUE-CONDITIONAL"
"ATOMIC-POP-SYMBOL-VALUE"
"ATOMIC-PUSHA"
"ATOMIC-PUSHD")
"ATOMIC-PUSHD"
"%UNARY-FROUND")
#+x87
(:export "%COS-QUICK" "%SIN-QUICK" "%TAN-QUICK")
;;#+double-double
......
......@@ -445,9 +445,7 @@
`(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))
(let ((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))
......
......@@ -23,7 +23,7 @@
%unary-ftruncate/single-float %unary-ftruncate/double-float))
#-x87
(export '(%unary-fround/single-float %unary-fround/double-float))
(export '(%unary-fround %unary-fround/single-float %unary-fround/double-float))
(in-package "LISP")
(export '(least-positive-normalized-short-float
......
......@@ -22,7 +22,9 @@
*bytes-consed-between-gcs* *gc-verbose* *gc-inhibit-hook*
*gc-notify-before* *gc-notify-after* get-bytes-consed
*gc-run-time* bytes-consed-between-gcs
get-bytes-consed-dfixnum))
get-bytes-consed-dfixnum
get-gc-assertions
set-gc-assertions))
(in-package "LISP")
(export '(room))
......@@ -72,10 +74,63 @@
(progn
(alien:def-alien-routine get_bytes_allocated_lower c-call:int)
(alien:def-alien-routine get_bytes_allocated_upper c-call:int)
(defun dynamic-usage ()
(dfixnum:dfixnum-pair-integer
(get_bytes_allocated_upper) (get_bytes_allocated_lower))))
(get_bytes_allocated_upper) (get_bytes_allocated_lower)))
;; Controls GC assertions that are enabled in the runtime. A value
;; of 0 disables all assertions (the normal default).
(alien:def-alien-variable ("gc_assert_level" gc-assert-level) c-call:int)
(alien:def-alien-variable ("verify_after_free_heap" gc-verify-after-free-heap) c-call:int)
(alien:def-alien-variable ("pre_verify_gen_0" gc-verify-new-objects) c-call:int)
(alien:def-alien-variable ("verify_gens" gc-verify-generations) c-call:int)
(defun get-gc-assertions ()
"Returns a list of the current GC assertion settings. The list is
in the same format as the keyword arguments to SET-GC-ASSERTIONS,
i.e.,
(apply #'set-gc-assertions (get-gc-assertions))
See SET-GC-ASSERTIONS for more information."
(list :assert-level gc-assert-level
:verify-after-free-heap (not (zerop gc-verify-after-free-heap))
:verify-generations gc-verify-generations
:verify-new-objects (not (zerop gc-verify-new-objects))))
(defun set-gc-assertions (&key (assert-level 0 assert-level-p)
(verify-after-free-heap nil verify-after-free-heap-p)
(verify-generations 6 verify-generations-p)
(verify-new-objects nil verify-new-objects-p))
"Set GC assertion to the specified value:
:ASSERT-LEVEL
Defaults to 0, higher values indicate more assertions are enabled.
:VERIFY-AFTER-FREE-HEAP
If non-NIL, the heap is verified for consistency whenever
part of the heap is collected.
:VERIFY-GENERATIONS
Set to generation number. When GC occurs, generations
equal to or higher than this value are checked for
consistency.
:VERIFY-NEW-OBJECTS
When GC occurs for the newest generation, the heap for this
generation is checked for validity.
"
(declare (type (and fixnum unsigned-byte) assert-level)
(type boolean verify-after-free-heap)
(type (integer 0 6) verify-generations)
(type boolean verify-new-objects))
(when assert-level-p
(setf gc-assert-level assert-level))
(when verify-after-free-heap-p
(setf gc-verify-after-free-heap (if verify-after-free-heap 1 0)))
(when verify-generations-p
(setf gc-verify-generations verify-generations))
(when verify-new-objects-p
(setf gc-verify-new-objects (if verify-new-objects 1 0)))
(values))
)
#+cgc
(c-var-frob dynamic-usage "bytes_allocated")
......
......@@ -492,7 +492,7 @@
(error 'simple-type-error
:expected-type '(or (integer 1) (float (0.0))) :datum arg
:format-control _"Argument is not a positive integer or a positive float: ~S")
:format-arguments (list arg)))))
:format-arguments (list arg))))
;; Jump function for the generator. See the jump function in
;; http://xoroshiro.di.unimi.it/xoroshiro128plus.c
......
......@@ -522,8 +522,18 @@
;; Make sure all the args are okay.
(unless (every #'simple-string-p args)
(error (intl:gettext "All args to program must be simple strings -- ~S.") args))
;; Make sure program is a string that we can use with spawn.
(setf program
(if (pathnamep program)
(lisp::with-pathname (p program)
(or (unix::unix-namestring p)
(namestring p)))
(namestring program)))
(check-type program string)
;; Prepend the program to the argument list.
(push (namestring program) args)
(push program args)
;; Clear random specials used by GET-DESCRIPTOR-FOR to communicate cleanup
;; info. Also, establish proc at this level so we can return it.
(let (*close-on-error* *close-in-parent* *handlers-installed* proc)
......@@ -566,9 +576,10 @@
(cdr entry)))
env))
(let ((child-pid
(without-gcing
(spawn program argv envp pty-name
stdin stdout stderr))))
(without-gcing
(spawn program
argv envp pty-name
stdin stdout stderr))))
(when (< child-pid 0)
(error (intl:gettext "Could not fork child process: ~A")
(unix:get-unix-error-msg)))
......
......@@ -60,14 +60,56 @@
#-cross-compiler
(defun machine-type ()
_N"Returns a string describing the type of the local machine."
"X86")
;; Use cpuid to get the processor type.
(with-output-to-string (s)
(multiple-value-bind (max-input ebx ecx edx)
(x86::cpuid 0)
(declare (ignore max-input))
(flet ((int-to-string (int)
(dotimes (k 4)
(let ((code (ldb (byte 8 (* 8 k)) int)))
;; Don't print out null chars. We're
;; assuming this only happens at the end
;; of the brand string.
(unless (zerop code)
(write-char (code-char code) s))))))
(int-to-string ebx)
(int-to-string edx)
(int-to-string ecx)))))
#-cross-compiler
(defun machine-version ()
_N"Returns a string describing the version of the local machine."
"X86")
;; UWe use the processor brand string method to get more detailed
;; information about the processor. If it's not available, just
;; give up, even though we could use the brand index (CPUID with
;; EAX=1) to get an identifier.
(let ((max-cpuid (x86::cpuid #x80000000)))
(cond ((or (not (logbitp 31 max-cpuid))
(< max-cpuid #x80000004))
;; Processor brand string not supported, just give up.
"X86")
(t
(with-output-to-string (s)
(labels ((int-to-string (int)
(dotimes (k 4)
(let ((code (ldb (byte 8 (* 8 k)) int)))
;; Don't print out null chars. We're
;; assuming this only happens at the end
;; of the brand string.
(unless (zerop code)
(write-char (code-char code) s)))))
(cpuid-to-string (input)
(multiple-value-bind (eax ebx ecx edx)
(x86::cpuid input)
(int-to-string eax)
(int-to-string ebx)
(int-to-string ecx)
(int-to-string edx))))
(cpuid-to-string #x80000002)
(cpuid-to-string #x80000003)
(cpuid-to-string #x80000004)))))))
;;; Fixup-Code-Object -- Interface
......
......@@ -38,7 +38,7 @@
;; 0-9 followed by a single hex digit in the range a-f. Then the
;; version looks like a decimal number followed by a minor release
;; letter of a to f.
(defconstant byte-fasl-file-version #x21c)
(defconstant byte-fasl-file-version #x21d)
(let* ((version-string (format nil "~X" byte-fasl-file-version)))
;; Add :cmu<n> to *features*
......
......@@ -1903,7 +1903,7 @@
(deftransform upgraded-complex-real-contagion-arg1 ((x y) * * :defun-only t :node node)
;;(format t "upgraded-complex-real-contagion-arg1~%")
`(,(continuation-function-name (basic-combination-fun node))
(coerce x '(complex ,(type-specifier (continuation-type y))))
(coerce x '(complex ,(numeric-type-format (continuation-type y))))
y))
;;;
(deftransform upgraded-complex-real-contagion-arg2 ((x y) * * :defun-only t :node node)
......@@ -1912,7 +1912,7 @@
(continuation-type x) (continuation-type y))
`(,(continuation-function-name (basic-combination-fun node))
x
(coerce y '(complex ,(type-specifier (continuation-type x))))))
(coerce y '(complex ,(numeric-type-format (continuation-type x))))))
(dolist (x '(= + * / -))
......@@ -2028,31 +2028,36 @@
(defun decode-float-exp-derive-type-aux (arg)
;; Derive the exponent part of the float. It's always an integer
;; type.
(flet ((calc-exp (x)
(when x
(nth-value 1 (decode-float x))))
(min-exp ()
;; Use decode-float on the least positive float of the
;; appropriate type to find the min exponent. If we don't
;; know the actual number format, use double, which has the
;; widest range (including double-double-float).
(nth-value 1 (decode-float (if (eq 'single-float (numeric-type-format arg))
least-positive-single-float
least-positive-double-float))))
(max-exp ()
;; Use decode-float on the most postive number of the
;; appropriate type to find the max exponent. If we don't
;; know the actual number format, use double, which has the
;; widest range (including double-double-float).
(if (eq (numeric-type-format arg) 'single-float)
(nth-value 1 (decode-float most-positive-single-float))
(nth-value 1 (decode-float most-positive-double-float)))))
(let* ((lo (or (bound-func #'calc-exp
(numeric-type-low arg))
(min-exp)))
(hi (or (bound-func #'calc-exp
(numeric-type-high arg))
(max-exp))))
(labels
((calc-exp (x)
(when x
(bound-func #'(lambda (arg)
(nth-value 1 (decode-float arg)))
x)))
(min-exp (interval)
;; (decode-float 0d0) returns an exponent of -1022. But
;; (decode-float least-positive-double-float returns -1073.
;; Hence, if the low value is less than this, we need to
;; return the exponent of the least positive number.
(let ((least (if (eq 'single-float (numeric-type-format arg))
least-positive-single-float
least-positive-double-float)))
(if (or (interval-contains-p 0 interval)
(interval-contains-p least interval))
(calc-exp least)
(calc-exp (bound-value (interval-low interval))))))
(max-exp (interval)
;; Use decode-float on the most postive number of the
;; appropriate type to find the max exponent. If we don't
;; know the actual number format, use double, which has the
;; widest range (including double-double-float).
(or (calc-exp (bound-value (interval-high interval)))
(calc-exp (if (eq 'single-float (numeric-type-format arg))
most-positive-single-float
most-positive-double-float)))))
(let* ((interval (interval-abs (numeric-type->interval arg)))
(lo (min-exp interval))
(hi (max-exp interval)))
(specifier-type `(integer ,(or lo '*) ,(or hi '*))))))
(defun decode-float-sign-derive-type-aux (arg)
......
......@@ -252,29 +252,32 @@
:ref-known (flushable foldable)
:set-trans (setf %array-fill-pointer)
:set-known (unsafe))
;; Don't let these ref-trans to be constant-folded because these
;; might get called on arrays that don't have these slots. (Because
;; the lisp functions might be inlined.)
(fill-pointer-p :type (member t nil)
:ref-trans %array-fill-pointer-p
:ref-known (flushable foldable)
:ref-known (flushable)
:set-trans (setf %array-fill-pointer-p)
:set-known (unsafe))
(elements :type index