common-lisp/sbcl.sbcl
1
0
Fork 0
mirror of git://git.code.sf.net/p/sbcl/sbcl synced 2026-09-10 07:26:40 -04:00
Code Issues Actions 8 Packages Projects Releases Wiki Activity

Fix sb-posix for 64-bit time_t.

Browse source
This commit is contained in:
Stas Boukarev 2025-01-17 05:19:04 +03:00
parent 966aefb714
commit f119986c69
9 changed files with 60 additions and 38 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

8
.github/workflows/linux-arm.yml vendored
View file

@ -23,9 +23,9 @@ jobs:
CC: arm-linux-gnueabihf-gcc
run: ./make.sh --xc-host='sbcl --dynamic-space-size 700MB --lose-on-corruption --disable-ldb --disable-debugger' --arch=arm
# - name: test
# env:
# CC: arm-linux-gnueabihf-gcc
# run: cd tests; ./run-tests.sh
- name: test
env:
CC: arm-linux-gnueabihf-gcc
run: cd tests; ./run-tests.sh
- name: ansi-test
run: cd tests; ./ansi-tests.sh

2
contrib/sb-grovel/def-to-lisp.lisp
View file

@ -197,6 +197,8 @@ code:
(split-cflags (sb-ext:posix-getenv "EXTRA_CFLAGS"))
#+(and linux largefile)
'("-D_LARGEFILE_SOURCE" "-D_LARGEFILE64_SOURCE" "-D_FILE_OFFSET_BITS=64")
#+64-bit-time
'("-D_TIME_BITS=64")
#+(and (or x86 ppc sparc) (or linux freebsd)) '("-m32")
#+(and x86-64 darwin inode64)
`("-arch" "x86_64" ,(format nil "-mmacosx-version-min=~A"

7
contrib/sb-posix/constants.lisp
View file

@ -424,7 +424,8 @@
;; utime(), utimes()
#-win32
(:type suseconds-t ; OAOOM warning: similar kludge in tools-for-build
#+os-provides-suseconds-t "suseconds_t"
#+(and os-provides-suseconds-t 64-bit-time) "__suseconds64_t"
#+(and os-provides-suseconds-t (not 64-bit-time)) "suseconds_t"
#-os-provides-suseconds-t "long")
#-win32
@ -436,7 +437,9 @@
(:structure alien-timeval
("struct timeval"
(time-t sec "time_t" "tv_sec")
(suseconds-t usec "suseconds_t" "tv_usec")))
(suseconds-t usec #+64-bit-time "__suseconds64_t"
#-64-bit-time "suseconds_t"
"tv_usec")))
(:integer veof "VEOF" nil t)
(:integer veol "VEOL" nil t)

60
contrib/sb-posix/interface.lisp
View file

@ -908,7 +908,8 @@ not supported."
(progn
(export 'time :sb-posix)
(defun time ()
(let ((result (alien-funcall (extern-alien "time"
(let ((result (alien-funcall (extern-alien #-64-bit-time "time"
#+64-bit-time "__time64"
(function time-t (* time-t)))
nil)))
(if (minusp result)
@ -916,18 +917,19 @@ not supported."
result)))
(export 'utime :sb-posix)
(defun utime (filename &optional access-time modification-time)
(with-alien ((fun (function int (c-string :not-null t) (* alien-utimbuf))
:extern #-netbsd "utime" #+netbsd "_utime"))
(let ((name (filename filename)))
(if (not (and access-time modification-time))
(alien-funcall fun name nil)
(with-alien ((utimbuf (struct alien-utimbuf)))
(setf (slot utimbuf 'actime) (or access-time 0)
(slot utimbuf 'modtime) (or modification-time 0))
(let ((result (alien-funcall fun name (alien-sap utimbuf))))
(if (minusp result)
(syscall-error 'utime)
result)))))))
(with-alien ((fun (function int (c-string :not-null t) (* alien-utimbuf))
:extern #-(or 64-bit-time netbsd) "utime" #+netbsd "_utime"
#+64-bit-time "__utime64"))
(let ((name (filename filename)))
(if (not (and access-time modification-time))
(alien-funcall fun name nil)
(with-alien ((utimbuf (struct alien-utimbuf)))
(setf (slot utimbuf 'actime) (or access-time 0)
(slot utimbuf 'modtime) (or modification-time 0))
(let ((result (alien-funcall fun name (alien-sap utimbuf))))
(if (minusp result)
(syscall-error 'utime)
result)))))))
(export 'utimes :sb-posix)
(defun utimes (filename &optional access-time modification-time)
(flet ((seconds-and-useconds (time)
@ -938,22 +940,22 @@ not supported."
(if (minusp value)
(syscall-error 'utimes)
value)))
(with-alien ((fun (function int (c-string :not-null t) (* (array alien-timeval 2)))
:extern #-netbsd "utimes" #+netbsd "sb_utimes"))
(let ((name (filename filename)))
(if (not (and access-time modification-time))
(maybe-syscall-error (alien-funcall fun name nil))
(with-alien ((buf (array alien-timeval 2)))
(let ((actime (deref buf 0))
(modtime (deref buf 1)))
(setf (values (slot actime 'sec)
(slot actime 'usec))
(seconds-and-useconds (or access-time 0))
(values (slot modtime 'sec)
(slot modtime 'usec))
(seconds-and-useconds (or modification-time 0)))
(maybe-syscall-error (alien-funcall fun name
(alien-sap buf)))))))))))
(with-alien ((fun (function int (c-string :not-null t) (* (array alien-timeval 2)))
:extern #-(or netbsd 64-bit-time) "utimes" #+(or netbsd 64-bit-time) "sb_utimes"))
(let ((name (filename filename)))
(if (not (and access-time modification-time))
(maybe-syscall-error (alien-funcall fun name nil))
(with-alien ((buf (array alien-timeval 2)))
(let ((actime (deref buf 0))
(modtime (deref buf 1)))
(setf (values (slot actime 'sec)
(slot actime 'usec))
(seconds-and-useconds (or access-time 0))
(values (slot modtime 'sec)
(slot modtime 'usec))
(seconds-and-useconds (or modification-time 0)))
(maybe-syscall-error (alien-funcall fun name
(alien-sap buf)))))))))))
;;; environment

2
tests/gc.impure.lisp
View file

@ -422,7 +422,7 @@
#+win32
(alien-funcall (extern-alien "Sleep" (function void int)) 300)
#-win32
(alien-funcall (extern-alien "sb_nanosleep" (function void int int)) 0 300000000)
(alien-funcall (extern-alien "sb_nanosleep" (function void sb-unix:time-t int)) 0 300000000)
(values a b c d e f g h i j k l m))))
(thr (sb-thread:make-thread (lambda ()
(let ((args #1=(list (LIST 'A) (LIST 'B) (LIST 'C)

3
tests/sleepytests.pure.lisp
View file

@ -8,7 +8,8 @@
;;; SLEEP should not cons except on 32-bit platforms when
;;; (> (mod seconds 1) (* most-positive-fixnum 1e-9))
(with-test (:name (sleep :non-consing)
:serial t :skipped-on :interpreter)
:serial t :skipped-on :interpreter
:fails-on (and :arm :64-bit-time))
(handler-case (sb-ext:with-timeout 5
(ctu:assert-no-consing (sleep 0.00001s0))
(locally (declare (notinline sleep))

8
tools-for-build/64-bit-time-test.c Normal file
View file

@ -0,0 +1,8 @@
#include <time.h>
int main ()
{
if (sizeof( time_t) == 8)
return 104;
return 1;
}

7
tools-for-build/grovel-features.sh
View file

@ -52,6 +52,13 @@ featurep os-provides-close-range-wrapper
featurep os-provides-posix-spawn
if [ "$sbcl_os" = linux ] ; then
case "$sbcl_arch" in
arm | x86 | ppc | mips | sparc | riscv32)
featurep 64-bit-time
esac
fi
if [ "$sbcl_arch" = arm ] ; then
featurep arm-softfp
fi

1
tools-for-build/os-provides-suseconds-t-test.c
View file

@ -1,4 +1,3 @@
/* test to build and run so that we know if we have blksize_t */
#include <sys/types.h>