Merge Lightening update branch

NEWS

@@ -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>)
 

check-guile.in

@@ -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="${top_srcdir}/test-suite"
-export TEST_SUITE_DIR
 
 if [ x"$1" = x-i ] ; then
-    guile=$2
+    guile="$2"
-    shift
+    shift 2
-    shift
 else
-    guile=${top_builddir}/meta/guile
+    guile="${top_builddir}/meta/guile"
 fi
 
-GUILE_LOAD_PATH=$TEST_SUITE_DIR
+export GUILE_LOAD_PATH="$TEST_SUITE_DIR"
-export GUILE_LOAD_PATH
 
 if [ -f "$guile" -a -x "$guile" ] ; then
-    echo Testing $guile ... "$@"
+    echo "Testing $guile ..." "$@"
-    echo with GUILE_LOAD_PATH=$GUILE_LOAD_PATH
+    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

doc/ref/api-io.texi

@@ -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:

doc/ref/api-procedures.texi

@@ -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

libguile/ports.c

@@ -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"
+            "On systems that support it, such as GNU/Linux, the following\n"
-	    "call is @code{lseek}.  @var{port} may be a string port.\n"
+            "constants can be used for @var{whence} to navigate ``holes'' in\n"
-	    "\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);

module/ice-9/eval-string.scm

@@ -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

module/ice-9/ports.scm

@@ -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)

module/srfi/srfi-19.scm

@@ -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)))

module/system/vm/linker.scm

@@ -770,15 +770,20 @@ Returns a bytevector."
           bv)
         (lambda (port)
           (define write-padding
-            (let ((blank (make-bytevector 4096 0)))
+            ;; Write SIZE bytes of padding to PORT.
-              (lambda (port size)
+            (if (file-port? port)
-                ;; Write SIZE bytes of padding to PORT.
+                (lambda (size)
-                (let loop ((size size))
+                  ;; Use 'seek' to create a sparse file.
-                  (unless (zero? size)
+                  (seek port size SEEK_CUR))
-                    (let ((count (min size
+                (let ((blank (make-bytevector 4096 0)))
-                                      (bytevector-length blank))))
+                  (lambda (size)
-                     (put-bytevector port blank 0 count)
+                    ;; Write SIZE zeros.
-                     (loop (- size count))))))))
+                    (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

test-suite/guile-test

@@ -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
+;;;; files whose names end in `.test' and don't begin with `.'.  (It
-;;;; Scheme code.)  However, you can have it execute specific tests by
+;;;; assumes they contain Scheme code.)  However, you can have it
-;;;; listing their filenames on the command line.
+;;;; 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)
+		     (when (string-suffix? ".test" file)
-			 (let ((short-name
+                       (let ((short-name (substring file root-len)))
-				(substring file root-len)))
+                         (unless (eqv? #\. (string-ref short-name 0))
-			   (set! tests (cons short-name tests))))
+			   (set! tests (cons short-name tests)))))
 		     #t)
 		   test-dir)
 

test-suite/standalone/test-bad-identifiers

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

test-suite/tests/eval-string.test

@@ -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))))

test-suite/tests/interp.test

@@ -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)

test-suite/tests/ports.test

@@ -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,
+;;;; 	Copyright (C) 1999, 2001, 2004, 2006-2007, 2009-2015, 2017, 2019-2021,
-;;;;      2011, 2012, 2013, 2014, 2015, 2017, 2019, 2020, 2021 Free Software Foundation, Inc.
+;;;;      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)))

test-suite/tests/r6rs-unicode.test

@@ -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.
 ;;

test-suite/tests/srfi-10.test

@@ -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)
 

test-suite/tests/srfi-19.test

@@ -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)