mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-04-29 19:30:36 +02:00
Code Activity

Merge Lightening update branch

Browse source
This commit is contained in:
Andy Wingo 2024-04-22 15:18:57 +02:00
commit e2fad20257
17 changed files with 179 additions and 73 deletions
Download patch file Download diff file Expand all files Collapse all files

9
NEWS
View file

@ -30,6 +30,13 @@ and 'never, with 'auto being the default.
This speeds up copying large files a lot while saving the disk space.
** 'seek' can now navigate holes in sparse files
On systems that support it, such as GNU/Linux, the new SEEK_DATA and
SEEK_HOLE values can now be passed to the 'seek' procedure to change
file offset to the next piece of data or to the next hole in sparse
files. See "Random Access" in the manual for details.
* Bug fixes
** (ice-9 suspendable-ports) incorrect UTF-8 decoding
@ -53,6 +60,8 @@ This speeds up copying large files a lot while saving the disk space.
** 'ftw' now correctly deals with directory permissions
(<https://bugs.gnu.org/55344>)
** 'make-custom-port' now honors its #:conversion-strategy argument
** 'eval-string' respects #:column (previously it was set to the #:line)
** 'string->date' now allows a colon in the ISO 8601 zone offset
** Hashing of UTF-8 symbols with non-ASCII characters avoids corruption
(<https://bugs.gnu.org/56413>)

24
check-guile.in
View file

@ -8,31 +8,29 @@
# ./check-guile numbers.test
# ./check-guile -i /usr/local/bin/guile
# ./check-guile -i /usr/local/bin/guile numbers.test
# ./check-guile -i meta/gdb-uninstalled-guile numbers.test
set -e
top_builddir=@top_builddir_absolute@
top_srcdir=@top_srcdir_absolute@
TEST_SUITE_DIR=${top_srcdir}/test-suite
export TEST_SUITE_DIR
export TEST_SUITE_DIR="${top_srcdir}/test-suite"
if [ x"$1" = x-i ] ; then
guile=$2
shift
shift
guile="$2"
shift 2
else
guile=${top_builddir}/meta/guile
guile="${top_builddir}/meta/guile"
fi
GUILE_LOAD_PATH=$TEST_SUITE_DIR
export GUILE_LOAD_PATH
export GUILE_LOAD_PATH="$TEST_SUITE_DIR"
if [ -f "$guile" -a -x "$guile" ] ; then
echo Testing $guile ... "$@"
echo with GUILE_LOAD_PATH=$GUILE_LOAD_PATH
echo "Testing $guile ..." "$@"
echo "with GUILE_LOAD_PATH=$GUILE_LOAD_PATH"
else
echo ERROR: Cannot execute $guile
echo "ERROR: Cannot execute $guile"
exit 1
fi
@ -41,11 +39,9 @@ if [ ! -f guile-procedures.txt ] ; then
@LN_S@ libguile/guile-procedures.txt .
fi
exec $guile \
exec "$guile" \
--debug \
-L "$TEST_SUITE_DIR" \
--no-auto-compile -e main -s "$TEST_SUITE_DIR/guile-test" \
--test-suite "$TEST_SUITE_DIR/tests" \
--log-file check-guile.log "$@"
# check-guile ends here

22
doc/ref/api-io.texi
View file

@ -823,8 +823,26 @@ Seek from the current position.
@defvar SEEK_END
Seek from the end of the file.
@end defvar
If @var{fd_port} is a file descriptor, the underlying system
call is @code{lseek}. @var{port} may be a string port.
On systems that support it, such as GNU/Linux, the following
constants can be used for @var{whence} to navigate ``holes'' in
sparse files:
@defvar SEEK_DATA
Seek to the next location in the file greater than or equal to
@var{offset} containing data. If @var{offset} points to data,
then the file offset is set to @var{offset}.
@end defvar
@defvar SEEK_HOLE
Seek to the next hole in the file greater than or equal to the
@var{offset}. If @var{offset} points into the middle of a hole,
then the file offset is set to @var{offset}. If there is no hole
past @var{offset}, then the file offset is adjusted to the end of
the file---i.e., there is an implicit hole at the end of any file.
@end defvar
If @var{fd_port} is a file descriptor, the underlying system call
is @code{lseek} (@pxref{File Position Primitive,,, libc, The GNU C
Library Reference Manual}). @var{port} may be a string port.
The value returned is the new position in @var{fd_port}. This means
that the current position of a port can be obtained using:

20
doc/ref/api-procedures.texi
View file

@ -186,26 +186,6 @@ Users must not modify the returned value unless they think they're
really clever.
@end deffn
@c FIXME
@deffn {Scheme Procedure} program-bindings program
@deffnx {Scheme Procedure} make-binding name boxed? index start end
@deffnx {Scheme Procedure} binding:name binding
@deffnx {Scheme Procedure} binding:boxed? binding
@deffnx {Scheme Procedure} binding:index binding
@deffnx {Scheme Procedure} binding:start binding
@deffnx {Scheme Procedure} binding:end binding
Bindings annotations for programs, along with their accessors.
Bindings declare names and liveness extents for block-local variables.
The best way to see what these are is to play around with them at a
REPL. @xref{VM Concepts}, for more information.
Note that bindings information is stored in a program as part of its
metadata thunk, so including it in the generated object code does not
impose a runtime performance penalty.
@end deffn
@deffn {Scheme Procedure} program-sources program
@deffnx {Scheme Procedure} source:addr source
@deffnx {Scheme Procedure} source:line source

42
libguile/ports.c
View file

@ -1,4 +1,4 @@
/* Copyright 1995-2001,2003-2004,2006-2019,2021
/* Copyright 1995-2001,2003-2004,2006-2019,2021,2024
Free Software Foundation, Inc.
This file is part of Guile.
@ -3713,9 +3713,26 @@ SCM_DEFINE (scm_seek, "seek", 3, 0, 0,
"@defvar SEEK_END\n"
"Seek from the end of the file.\n"
"@end defvar\n"
"If @var{fd_port} is a file descriptor, the underlying system\n"
"call is @code{lseek}. @var{port} may be a string port.\n"
"\n"
"On systems that support it, such as GNU/Linux, the following\n"
"constants can be used for @var{whence} to navigate ``holes'' in\n"
"sparse files:\n"
"@defvar SEEK_DATA\n"
"Seek to the next location in the file greater than or equal to\n"
"@var{offset} containing data. If @var{offset} points to data,\n"
"then the file offset is set to @var{offset}.\n"
"@end defvar\n"
"@defvar SEEK_HOLE\n"
"Seek to the next hole in the file greater than or equal to the\n"
"@var{offset}. If @var{offset} points into the middle of a hole,\n"
"then the file offset is set to @var{offset}. If there is no hole\n"
"past @var{offset}, then the file offset is adjusted to the end of\n"
"the file---i.e., there is an implicit hole at the end of any file.\n"
"@end defvar\n"
"\n"
"If @var{fd_port} is a file descriptor, the underlying system call\n"
"is @code{lseek} (@pxref{File Position Primitive,,, libc, The GNU C\n"
"Library Reference Manual}). @var{port} may be a string port.\n"
"\n"
"The value returned is the new position in the file. This means\n"
"that the current position of a port can be obtained using:\n"
"@lisp\n"
@ -3728,7 +3745,14 @@ SCM_DEFINE (scm_seek, "seek", 3, 0, 0,
fd_port = SCM_COERCE_OUTPORT (fd_port);
how = scm_to_int (whence);
if (how != SEEK_SET && how != SEEK_CUR && how != SEEK_END)
if (how != SEEK_SET && how != SEEK_CUR && how != SEEK_END
#ifdef SEEK_DATA
&& how != SEEK_DATA
#endif
#ifdef SEEK_HOLE
&& how != SEEK_HOLE
#endif
)
SCM_OUT_OF_RANGE (3, whence);
if (SCM_OPPORTP (fd_port))
@ -4151,6 +4175,14 @@ scm_init_ice_9_ports (void)
scm_c_define ("SEEK_CUR", scm_from_int (SEEK_CUR));
scm_c_define ("SEEK_END", scm_from_int (SEEK_END));
/* Support for sparse files (glibc). */
#ifdef SEEK_DATA
scm_c_define ("SEEK_DATA", scm_from_int (SEEK_DATA));
#endif
#ifdef SEEK_HOLE
scm_c_define ("SEEK_HOLE", scm_from_int (SEEK_HOLE));
#endif
scm_c_define ("%current-input-port-fluid", cur_inport_fluid);
scm_c_define ("%current-output-port-fluid", cur_outport_fluid);
scm_c_define ("%current-error-port-fluid", cur_errport_fluid);

2
module/ice-9/eval-string.scm
View file

@ -81,7 +81,7 @@
(if line
(set-port-line! port line))
(if column
(set-port-column! port line))
(set-port-column! port column))
(if (or compile? (not (language-evaluator lang)))
((load-thunk-from-memory

8
module/ice-9/ports.scm
View file

@ -1,5 +1,5 @@
;;; Ports
;;; Copyright (C) 2016,2019,2021 Free Software Foundation, Inc.
;;; Copyright (C) 2016,2019,2021,2024 Free Software Foundation, Inc.
;;;
;;; This library is free software: you can redistribute it and/or modify
;;; it under the terms of the GNU Lesser General Public License as
@ -153,6 +153,12 @@
(load-extension (string-append "libguile-" (effective-version))
"scm_init_ice_9_ioext")
(eval-when (load eval expand)
(when (defined? 'SEEK_DATA)
(module-export! (current-module) '(SEEK_DATA)))
(when (defined? 'SEEK_HOLE)
(module-export! (current-module) '(SEEK_HOLE))))
(define (port-encoding port)

2
module/srfi/srfi-19.scm
View file

@ -1268,6 +1268,8 @@
(set! offset (+ offset (* (char->int ch)
60 60))))
(let ((ch (read-char port)))
(if (eqv? ch #\:)
(set! ch (read-char port)))
(if (eof-object? ch)
(time-error 'string->date 'bad-date-template-string
(list "Invalid time zone number" ch)))

25
module/system/vm/linker.scm
View file

@ -770,15 +770,20 @@ Returns a bytevector."
bv)
(lambda (port)
(define write-padding
(let ((blank (make-bytevector 4096 0)))
(lambda (port size)
;; Write SIZE bytes of padding to PORT.
(let loop ((size size))
(unless (zero? size)
(let ((count (min size
(bytevector-length blank))))
(put-bytevector port blank 0 count)
(loop (- size count))))))))
;; Write SIZE bytes of padding to PORT.
(if (file-port? port)
(lambda (size)
;; Use 'seek' to create a sparse file.
(seek port size SEEK_CUR))
(let ((blank (make-bytevector 4096 0)))
(lambda (size)
;; Write SIZE zeros.
(let loop ((size size))
(unless (zero? size)
(let ((count (min size
(bytevector-length blank))))
(put-bytevector port blank 0 count)
(loop (- size count)))))))))
(define (compute-padding objects)
;; Return the list of padding in between OBJECTS--the list
@ -802,7 +807,7 @@ Returns a bytevector."
(for-each
(lambda (object padding)
(let ((bv (make-bytevector (linker-object-size object) 0)))
(write-padding port padding)
(write-padding padding)
(write-linker-object bv object symtab endianness)
(put-bytevector port bv)))
objects

16
test-suite/guile-test
View file

@ -32,9 +32,10 @@
;;;; fail or pass unexpectedly.
;;;;
;;;; Normally, guile-test scans the test directory, and executes all
;;;; files whose names end in `.test'. (It assumes they contain
;;;; Scheme code.) However, you can have it execute specific tests by
;;;; listing their filenames on the command line.
;;;; files whose names end in `.test' and don't begin with `.'. (It
;;;; assumes they contain Scheme code.) However, you can have it
;;;; execute specific tests by listing their filenames on the command
;;;; line.
;;;;
;;;; The option `--test-suite' can be given to specify the test
;;;; directory. If no such option is given, the test directory is
@ -81,6 +82,7 @@
(apply (module-ref module 'main) args)))
(define-module (test-suite guile-test)
:declarative? #f
:use-module (test-suite lib)
:use-module (ice-9 getopt-long)
:use-module (ice-9 and-let-star)
@ -158,10 +160,10 @@
(let ((root-len (+ 1 (string-length test-dir)))
(tests '()))
(for-each-file (lambda (file)
(if (string-suffix? ".test" file)
(let ((short-name
(substring file root-len)))
(set! tests (cons short-name tests))))
(when (string-suffix? ".test" file)
(let ((short-name (substring file root-len)))
(unless (eqv? #\. (string-ref short-name 0))
(set! tests (cons short-name tests)))))
#t)
test-dir)

13
test-suite/standalone/test-bad-identifiers
View file

@ -44,14 +44,11 @@ exec guile -q -s "$0" "$@"
acc
(cons (in-vicinity dir new) acc)))))))
(define (directory-files-matching dir pattern)
(let ((file-name-regexp (make-regexp pattern)))
(filter (lambda (fn)
(regexp-exec file-name-regexp fn))
(directory-files dir))))
(let loop ((file-names (directory-files-matching "../../libguile"
"\\.[ch]$")))
(let loop ((file-names (filter (lambda (fn)
(and (or (string-suffix? ".h" fn)
(string-suffix? ".c" fn))
(not (string-prefix? "." (basename fn)))))
(directory-files "../../libguile"))))
(or (null? file-names)
(begin
(with-input-from-file (car file-names)

7
test-suite/tests/eval-string.test
View file

@ -51,4 +51,9 @@
(equal? (call-with-values (lambda ()
(eval-string "(values 1 2)" #:compile? #t))
list)
'(1 2))))
'(1 2)))
(pass-if-equal "source properties"
'((filename . "test.scm") (line . 3) (column . 42))
(source-properties
(eval-string "'(1 2)" #:file "test.scm" #:line 3 #:column 41))))

3
test-suite/tests/interp.test
View file

@ -16,6 +16,9 @@
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-suite test-interp)
#:use-module (test-suite lib))
(pass-if "Internal defines 1"
(letrec ((foo (lambda (arg)
(or arg (and (procedure? foo)

50
test-suite/tests/ports.test
View file

@ -1,8 +1,8 @@
;;;; ports.test --- Guile I/O ports. -*- coding: utf-8; mode: scheme; -*-
;;;; Jim Blandy <jimb@red-bean.com> --- May 1999
;;;;
;;;; Copyright (C) 1999, 2001, 2004, 2006, 2007, 2009, 2010,
;;;; 2011, 2012, 2013, 2014, 2015, 2017, 2019, 2020, 2021 Free Software Foundation, Inc.
;;;; Copyright (C) 1999, 2001, 2004, 2006-2007, 2009-2015, 2017, 2019-2021,
;;;; 2024 Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public
@ -185,6 +185,52 @@
(close-port iport))
(delete-file filename))
(let* ((file (test-file))
(port (open-output-file file)))
(seek port 4096 SEEK_SET)
(display "bye." port)
(close-port port)
(pass-if-equal "size of sparse file"
4100
(stat:size (stat file)))
(pass-if-equal "SEEK_DATA while on data"
4096
(if (defined? 'SEEK_DATA)
(call-with-input-file file
(lambda (port)
(catch 'system-error
(lambda ()
(seek port 4096 SEEK_DATA))
(lambda _
(throw 'unresolved)))))
(throw 'unresolved)))
(pass-if-equal "SEEK_DATA while in hole"
4096
(if (defined? 'SEEK_DATA)
(call-with-input-file file
(lambda (port)
(catch 'system-error
(lambda ()
(seek port 10 SEEK_DATA))
(lambda _
(throw 'unresolved)))))
(throw 'unresolved)))
(pass-if-equal "SEEK_HOLE while in hole"
10
(if (defined? 'SEEK_HOLE)
(call-with-input-file file
(lambda (port)
(catch 'system-error
(lambda ()
(seek port 10 SEEK_HOLE))
(lambda _
(throw 'unresolved)))))
(throw 'unresolved))))
;;; unusual characters.
(let* ((filename (test-file))
(port (open-output-file filename)))

2
test-suite/tests/r6rs-unicode.test
View file

@ -1,4 +1,4 @@
;;; r6rs-unicode.test --- Test suite for R6RS (rnrs unicode)
;;; r6rs-unicode.test --- Test suite for R6RS (rnrs unicode) -*-scheme-*-
;; Copyright (C) 2010 Free Software Foundation, Inc.
;;

4
test-suite/tests/srfi-10.test
View file

@ -17,7 +17,9 @@
;;;; License along with this library; if not, write to the Free Software
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(use-modules (srfi srfi-10))
(use-modules
(srfi srfi-10)
((test-suite lib) #:select (pass-if with-test-prefix)))
(define-reader-ctor 'rx make-regexp)

3
test-suite/tests/srfi-19.test
View file

@ -120,6 +120,9 @@ incomplete numerical tower implementation.)"
(pass-if "string->date works"
(begin (string->date "2001-06-01@14:00" "~Y-~m-~d@~H:~M")
#t))
(pass-if "string->date accepts ISO 8601 zones with a colon"
(begin (string->date "2024-12-31T23:59:59+01:00" "~Y-~m-~dT~H:~M:~S~z")
#t))
;; check for code paths where reals were passed to quotient, which
;; doesn't work in Guile (and is unspecified in R5RS)
(test-time->date time-utc->date date->time-utc)