summaryrefslogtreecommitdiff
path: root/test-suite
diff options
context:
space:
mode:
Diffstat (limited to 'test-suite')
-rw-r--r--test-suite/tests/compiler.test25
-rw-r--r--test-suite/tests/coverage.test5
-rw-r--r--test-suite/tests/elisp-reader.test10
-rw-r--r--test-suite/tests/ephemerons.test46
-rw-r--r--test-suite/tests/eval-string.test18
-rw-r--r--test-suite/tests/gc.test5
-rw-r--r--test-suite/tests/hash.test10
-rw-r--r--test-suite/tests/modules.test43
-rw-r--r--test-suite/tests/reader.test23
-rw-r--r--test-suite/tests/srcprop.test10
-rw-r--r--test-suite/tests/srfi-105.test39
-rw-r--r--test-suite/tests/srfi-119.test20
-rw-r--r--test-suite/tests/srfi-69.test6
-rw-r--r--test-suite/tests/syntax.test4
-rw-r--r--test-suite/tests/tree-il.test74
-rw-r--r--test-suite/tests/types.test4
-rw-r--r--test-suite/tests/weaks.test147
17 files changed, 220 insertions, 269 deletions
diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test
index 0b47d0e32..cf0ea52de 100644
--- a/test-suite/tests/compiler.test
+++ b/test-suite/tests/compiler.test
@@ -1,5 +1,5 @@
;;;; compiler.test --- tests for the compiler -*- scheme -*-
-;;;; Copyright (C) 2008-2014, 2018, 2021-2022, 2024 Free Software Foundation, Inc.
+;;;; Copyright (C) 2008-2014, 2018, 2021-2022, 2024, 2025 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
@@ -75,14 +75,11 @@
(eq? round (module-ref m 'round))))
(pass-if-equal "syntax-source with read-hash-extend"
- '((filename . "sample.scm") (line . 2) (column . 5))
- ;; In Guile 3.0.8, psyntax would dismiss source properties added by
- ;; read hash extensions on data they return.
- ;; See <https://issues.guix.gnu.org/54003>
+ #("sample.scm" 2 5)
(with-fluids ((%read-hash-procedures
(fluid-ref %read-hash-procedures)))
(read-hash-extend #\~ (lambda (chr port)
- (list 'magic (read port))))
+ (list 'magic (read-syntax port))))
(tree-il-src
(car
(call-args
@@ -156,20 +153,26 @@
;; with IP 0 of a VM program, which corresponds to the entry point. See
;; also <http://savannah.gnu.org/bugs/?29817> for details.
+ (define (compile-string str)
+ (call-with-input-string str
+ (lambda (port)
+ (read-and-compile port #:to 'value))))
+
(pass-if "lambda"
- (let ((s (program-sources (compile '(lambda (x) x)))))
+ (let ((s (program-sources (compile-string "(lambda (x) x)"))))
(not (not (memv 0 (map source:addr s))))))
(pass-if "lambda*"
(let ((s (program-sources
- (compile '(lambda* (x #:optional y) x)))))
+ (compile-string "(lambda* (x #:optional y) x)"))))
(not (not (memv 0 (map source:addr s))))))
(pass-if "case-lambda"
(let ((s (program-sources
- (compile '(case-lambda (() #t)
- ((y) y)
- ((y z) (list y z)))))))
+ (compile-string
+ "(case-lambda (() #t)
+ ((y) y)
+ ((y z) (list y z)))"))))
(not (not (memv 0 (map source:addr s))))))))
(with-test-prefix "case-lambda"
diff --git a/test-suite/tests/coverage.test b/test-suite/tests/coverage.test
index 5f393b6b0..d1b954cd5 100644
--- a/test-suite/tests/coverage.test
+++ b/test-suite/tests/coverage.test
@@ -1,6 +1,6 @@
;;;; coverage.test --- Code coverage. -*- mode: scheme; coding: utf-8; -*-
;;;;
-;;;; Copyright (C) 2010, 2011, 2012, 2013, 2014, 2015, 2017 Free Software Foundation, Inc.
+;;;; Copyright (C) 2010, 2011, 2012, 2013, 2014, 2015, 2017, 2025 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
@@ -30,8 +30,7 @@
((_ filename snippet)
(let ((input (open-input-string snippet)))
(set-port-filename! input filename)
- (read-enable 'positions)
- (compile (read input))))))
+ (compile (read-syntax input))))))
(define test-procedure
(compile '(lambda (x)
diff --git a/test-suite/tests/elisp-reader.test b/test-suite/tests/elisp-reader.test
index cf7c15c52..f6d385a27 100644
--- a/test-suite/tests/elisp-reader.test
+++ b/test-suite/tests/elisp-reader.test
@@ -1,6 +1,7 @@
+;;;; -*- scheme -*-
;;;; elisp-reader.test --- Test the reader used by the Elisp compiler.
;;;;
-;;;; Copyright (C) 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009, 2025 Free Software Foundation, Inc.
;;;; Daniel Kraft
;;;;
;;;; This library is free software; you can redistribute it and/or
@@ -18,9 +19,10 @@
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-elisp-reader)
- :use-module (test-suite lib)
- :use-module (language elisp lexer)
- :use-module (language elisp parser))
+ #:use-module (test-suite lib)
+ #:use-module (ice-9 source-properties)
+ #:use-module (language elisp lexer)
+ #:use-module (language elisp parser))
; ==============================================================================
diff --git a/test-suite/tests/ephemerons.test b/test-suite/tests/ephemerons.test
index af8108a59..f37c0ff3b 100644
--- a/test-suite/tests/ephemerons.test
+++ b/test-suite/tests/ephemerons.test
@@ -27,14 +27,10 @@
(pass-if (ephemeron? (make-ephemeron (cons 42 42) 42)))
(with-test-prefix "ephemeron key not heap object"
- (pass-if-exception "fixnum" exception:wrong-type-arg
- (make-ephemeron 42 42))
- (pass-if-exception "char" exception:wrong-type-arg
- (make-ephemeron #\a 42))
- (pass-if-exception "bool" exception:wrong-type-arg
- (make-ephemeron #f 42))
- (pass-if-exception "bool" exception:wrong-type-arg
- (make-ephemeron #t 42)))
+ (pass-if "fixnum" (ephemeron? (make-ephemeron 42 42)))
+ (pass-if "char" (ephemeron? (make-ephemeron #\a 42)))
+ (pass-if "bool" (ephemeron? (make-ephemeron #f 42)))
+ (pass-if "bool" (ephemeron? (make-ephemeron #t 42))))
(let ((x (cons 42 69)))
(define e (make-ephemeron x 100))
@@ -44,8 +40,42 @@
(pass-if (ephemeron? e))
(pass-if (eq? x (ephemeron-key e)))
(pass-if-equal 100 (ephemeron-value e))
+ (pass-if-equal 100 (ephemeron-swap! e 'qux))
+ (pass-if-equal 'qux (ephemeron-value e))
(ephemeron-mark-dead! e)
(pass-if (ephemeron? e))
(pass-if-equal #f (ephemeron-key e))
(pass-if-equal #f (ephemeron-value e))))
+
+(with-test-prefix "ephemeron tables"
+
+ (define et (make-ephemeron-table 47))
+ (pass-if (ephemeron-table? et))
+
+ (define keys (map list (iota 47)))
+
+ (for-each (lambda (idx)
+ (pass-if (not (ephemeron-table-ref et idx))))
+ (iota 47))
+ (for-each (lambda (idx key)
+ (ephemeron-table-push! et idx (make-ephemeron key #t)))
+ (iota 47) keys)
+ (for-each (lambda (idx)
+ (define head (ephemeron-table-ref et idx))
+ (pass-if (ephemeron? head))
+ (pass-if-equal (list idx) (ephemeron-key head))
+ (pass-if (ephemeron-value head))
+ (pass-if (not (ephemeron-next head))))
+ (iota 47))
+
+ (define prev (ephemeron-table-ref et 42))
+ (pass-if-equal prev
+ (ephemeron-table-try-push! et 42 (make-ephemeron 'hey 'qux) #f))
+ (pass-if-equal prev
+ (ephemeron-table-try-push! et 42 (make-ephemeron 'hey 'qux) prev))
+ (pass-if-equal 'hey (ephemeron-key (ephemeron-table-ref et 42)))
+ (pass-if-equal prev (ephemeron-next (ephemeron-table-ref et 42)))
+ (pass-if-equal (list 42)
+ (ephemeron-key (ephemeron-next (ephemeron-table-ref et 42))))
+ (pass-if (not (ephemeron-next (ephemeron-next (ephemeron-table-ref et 42))))))
diff --git a/test-suite/tests/eval-string.test b/test-suite/tests/eval-string.test
index 33068a272..a48718a10 100644
--- a/test-suite/tests/eval-string.test
+++ b/test-suite/tests/eval-string.test
@@ -1,5 +1,5 @@
;;;; eval-string.test --- tests for (ice-9 eval-string) -*- scheme -*-
-;;;; Copyright (C) 2011 Free Software Foundation, Inc.
+;;;; Copyright (C) 2011, 2025 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
@@ -17,7 +17,8 @@
(define-module (test-suite test-eval-string)
#:use-module (test-suite lib)
- #:use-module (ice-9 eval-string))
+ #:use-module (ice-9 eval-string)
+ #:use-module (ice-9 match))
(with-test-prefix "basic"
@@ -53,7 +54,12 @@
list)
'(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))))
+ (pass-if-equal "source locations" "test.scm:4:41"
+ (match (string-split
+ (object->string
+ (eval-string "(lambda () 42)"
+ #:file "test.scm" #:line 3 #:column 41
+ #:compile? #t))
+ #\space)
+ (("#<procedure" addr "at" loc "()>")
+ loc))))
diff --git a/test-suite/tests/gc.test b/test-suite/tests/gc.test
index ab710f28d..380690733 100644
--- a/test-suite/tests/gc.test
+++ b/test-suite/tests/gc.test
@@ -19,6 +19,7 @@
(define-module (tests gc)
#:use-module (ice-9 documentation)
#:use-module (ice-9 guardians)
+ #:use-module (ice-9 weak-tables)
#:use-module (test-suite lib)
#:use-module ((system base compile) #:select (compile)))
@@ -49,9 +50,9 @@
(pass-if "weak-values versus records"
(let ((rec-type (make-record-type 'foo '()))
(h (make-weak-value-hash-table 61)))
- (hash-set! h "foo" ((record-constructor rec-type)))
+ (weak-value-hash-table-set! h "foo" ((record-constructor rec-type)))
(gc)
- (let ((x (hash-ref h "foo")))
+ (let ((x (weak-value-hash-table-ref h "foo")))
(or (not x)
((record-predicate rec-type) x)))))
diff --git a/test-suite/tests/hash.test b/test-suite/tests/hash.test
index 779043c9a..f95ec0281 100644
--- a/test-suite/tests/hash.test
+++ b/test-suite/tests/hash.test
@@ -1,7 +1,7 @@
;;;; hash.test --- test guile hashing -*- scheme -*-
;;;;
;;;; Copyright (C) 2004, 2005, 2006, 2008, 2011, 2012,
-;;;; 2014, 2020 Free Software Foundation, Inc.
+;;;; 2014, 2020, 2025 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
@@ -20,7 +20,8 @@
(define-module (test-suite test-numbers)
#:use-module (test-suite lib)
#:use-module (ice-9 documentation)
- #:use-module (ice-9 hash-table))
+ #:use-module (ice-9 hash-table)
+ #:use-module (ice-9 weak-tables))
;;;
;;; hash
@@ -365,7 +366,8 @@
(with-test-prefix "weak key hash table"
(pass-if "hash-for-each after gc"
(let ((table (make-weak-key-hash-table)))
- (hashq-set! table (list 'foo) 'bar)
+ (weak-key-hash-table-set! table (list 'foo) 'bar)
(gc)
;; Iterate over deleted weak ref without crashing.
- (unspecified? (hash-for-each (lambda (key value) key) table)))))
+ (weak-key-hash-table-for-each (lambda (key value) key) table)
+ #t)))
diff --git a/test-suite/tests/modules.test b/test-suite/tests/modules.test
index de595c02d..2a309a470 100644
--- a/test-suite/tests/modules.test
+++ b/test-suite/tests/modules.test
@@ -1,6 +1,6 @@
;;;; modules.test --- exercise some of guile's module stuff -*- scheme -*-
-;;;; Copyright (C) 2006, 2007, 2009-2011, 2014, 2019 Free Software Foundation, Inc.
+;;;; Copyright (C) 2006, 2007, 2009-2011, 2014, 2019, 2025 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
@@ -212,49 +212,16 @@
(with-test-prefix "observers"
- (pass-if "weak observer invoked"
+ (pass-if "observer invoked"
(let* ((m (make-module))
(invoked 0))
- (module-observe-weak m (lambda (mod)
- (if (eq? mod m)
- (set! invoked (+ invoked 1)))))
+ (module-observe m (lambda (mod)
+ (if (eq? mod m)
+ (set! invoked (+ invoked 1)))))
(module-define! m 'something 2)
(module-define! m 'something-else 1)
(= invoked 2)))
- (pass-if "all weak observers invoked"
- ;; With the two-argument `module-observe-weak' available in previous
- ;; versions, the observer would get unregistered as soon as the observing
- ;; closure gets GC'd, making it impossible to use an anonymous lambda as
- ;; the observing procedure.
-
- (let* ((m (make-module))
- (observer-count 500)
- (observer-ids (let loop ((i observer-count)
- (ids '()))
- (if (= i 0)
- ids
- (loop (- i 1) (cons (make-module) ids)))))
- (observers-invoked (make-hash-table observer-count)))
-
- ;; register weak observers
- (for-each (lambda (id)
- (module-observe-weak m id
- (lambda (m)
- (hashq-set! observers-invoked
- id #t))))
- observer-ids)
-
- (gc)
-
- ;; invoke them
- (module-call-observers m)
-
- ;; make sure all of them were invoked
- (->bool (every (lambda (id)
- (hashq-ref observers-invoked id))
- observer-ids))))
-
(pass-if "imported bindings updated"
(let ((m (make-module))
(imported (make-module)))
diff --git a/test-suite/tests/reader.test b/test-suite/tests/reader.test
index 27daf6106..8d2a3d415 100644
--- a/test-suite/tests/reader.test
+++ b/test-suite/tests/reader.test
@@ -1,6 +1,6 @@
;;;; reader.test --- Reader test. -*- coding: iso-8859-1; mode: scheme -*-
;;;;
-;;;; Copyright (C) 1999, 2001-2003, 2007-2011, 2013-2015, 2020-2022
+;;;; Copyright (C) 1999, 2001-2003, 2007-2011, 2013-2015, 2020-2022, 2025
;;;; Free Software Foundation, Inc.
;;;;
;;;; Jim Blandy <jimb@red-bean.com>
@@ -20,6 +20,7 @@
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-suite reader)
+ #:use-module (ice-9 source-properties)
#:use-module (srfi srfi-1)
#:use-module (test-suite lib)
#:use-module (system syntax internal))
@@ -304,30 +305,18 @@
(with-read-options '(keywords postfix)
(lambda ()
(read-string ":")))))
- (pass-if "no positions"
- (let ((sexp (with-read-options '()
- (lambda ()
- (read-string "(+ 1 2 3)")))))
- (and (not (source-property sexp 'line))
- (not (source-property sexp 'column)))))
(pass-if "positions"
- (let ((sexp (with-read-options '(positions)
- (lambda ()
- (read-string "(+ 1 2 3)")))))
+ (let ((sexp (read-string "(+ 1 2 3)")))
(and (equal? (source-property sexp 'line) 0)
(equal? (source-property sexp 'column) 0))))
(pass-if "positions on quote"
- (let ((sexp (with-read-options '(positions)
- (lambda ()
- (read-string "'abcde")))))
+ (let ((sexp (read-string "'abcde")))
(and (equal? (source-property sexp 'line) 0)
(equal? (source-property sexp 'column) 0))))
(pass-if "position of SCSH block comment"
;; In Guile 2.0.0 the reader would not update the port's position
;; when reading an SCSH block comment.
- (let ((sexp (with-read-options '(positions)
- (lambda ()
- (read-string "#!foo\nbar\nbaz\n!#\n(hello world)\n")))))
+ (let ((sexp (read-string "#!foo\nbar\nbaz\n!#\n(hello world)\n")))
(= 4 (source-property sexp 'line))))
(with-test-prefix "r6rs-hex-escapes"
@@ -558,7 +547,7 @@
read-syntax)))
(pass-if-equal "syntax-source"
- '((filename . "sample.scm") (line . 2) (column . 3))
+ #("sample.scm" 2 3)
(syntax-source
(call-with-input-string "\
;; first line
diff --git a/test-suite/tests/srcprop.test b/test-suite/tests/srcprop.test
index 4afc31802..d5f27744f 100644
--- a/test-suite/tests/srcprop.test
+++ b/test-suite/tests/srcprop.test
@@ -1,6 +1,6 @@
;;;; srcprop.test --- test Guile source properties -*- scheme -*-
;;;;
-;;;; Copyright (C) 2003, 2006, 2009 Free Software Foundation, Inc.
+;;;; Copyright (C) 2003, 2006, 2009, 2025 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
@@ -17,7 +17,8 @@
;;;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
(define-module (test-suite test-srcprop)
- :use-module (test-suite lib))
+ #:use-module (ice-9 source-properties)
+ #:use-module (test-suite lib))
;;;
@@ -29,7 +30,6 @@
(pass-if "no props"
(null? (source-properties (list 1 2 3))))
- (read-enable 'positions)
(with-test-prefix "read properties"
(define (reads-with-srcprops? str)
(let ((x (read (open-input-string str))))
@@ -76,8 +76,6 @@
;;;
(with-test-prefix "set-source-property!"
- (read-enable 'positions)
-
(pass-if "setting the breakpoint property works"
(let ((s (read (open-input-string "(+ 3 4)"))))
(throw 'unresolved)
@@ -100,8 +98,6 @@
;;;
(with-test-prefix "set-source-properties!"
- (read-enable 'positions)
-
(pass-if "setting the breakpoint property works"
(let ((s (read (open-input-string "(+ 3 4)"))))
(throw 'unresolved)
diff --git a/test-suite/tests/srfi-105.test b/test-suite/tests/srfi-105.test
index 34ea47b55..201a6b824 100644
--- a/test-suite/tests/srfi-105.test
+++ b/test-suite/tests/srfi-105.test
@@ -1,6 +1,6 @@
;;;; srfi-105.test --- Test suite for Guile's SRFI-105 reader. -*- scheme -*-
;;;;
-;;;; Copyright (C) 2012, 2013 Free Software Foundation, Inc.
+;;;; Copyright (C) 2012, 2013, 2025 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
@@ -18,6 +18,7 @@
(define-module (test-srfi-105)
#:use-module (test-suite lib)
+ #:use-module (ice-9 source-properties)
#:use-module (srfi srfi-1))
(define (read-string s)
@@ -139,50 +140,22 @@
(pass-if (equal? '{e[1 2]} '($bracket-apply$ e 1 2)))
(pass-if (equal? '{e[1 . 2]} '($bracket-apply$ e 1 . 2)))
- ;; Verify that source position information is not recorded if not
- ;; asked for.
- (with-test-prefix "no positions"
- (pass-if "simple curly-infix list"
- (let ((sexp (with-read-options '(curly-infix)
- (lambda ()
- (read-string " {1 + 2 + 3}")))))
- (and (not (source-property sexp 'line))
- (not (source-property sexp 'column)))))
- (pass-if "mixed curly-infix list"
- (let ((sexp (with-read-options '(curly-infix)
- (lambda ()
- (read-string " {1 + 2 * 3}")))))
- (and (not (source-property sexp 'line))
- (not (source-property sexp 'column)))))
- (pass-if "singleton curly-infix list"
- (let ((sexp (with-read-options '(curly-infix)
- (lambda ()
- (read-string " { 1.0 }")))))
- (and (not (source-property sexp 'line))
- (not (source-property sexp 'column)))))
- (pass-if "neoteric expression"
- (let ((sexp (with-read-options '(curly-infix)
- (lambda ()
- (read-string " { f(x) }")))))
- (and (not (source-property sexp 'line))
- (not (source-property sexp 'column))))))
-
;; Verify that source position information is properly recorded.
(with-test-prefix "positions"
(pass-if "simple curly-infix list"
- (let ((sexp (with-read-options '(curly-infix positions)
+ (let ((sexp (with-read-options '(curly-infix)
(lambda ()
(read-string " {1 + 2 + 3}")))))
(and (equal? (source-property sexp 'line) 0)
(equal? (source-property sexp 'column) 1))))
(pass-if "mixed curly-infix list"
- (let ((sexp (with-read-options '(curly-infix positions)
+ (let ((sexp (with-read-options '(curly-infix)
(lambda ()
(read-string " {1 + 2 * 3}")))))
(and (equal? (source-property sexp 'line) 0)
(equal? (source-property sexp 'column) 1))))
(pass-if "singleton curly-infix list"
- (let ((sexp (with-read-options '(curly-infix positions)
+ (let ((sexp (with-read-options '(curly-infix)
(lambda ()
(read-string " { 1.0 }")))))
(and (equal? (source-property sexp 'line) 0)
@@ -191,7 +164,7 @@
((3) #t)
(else #f)))))
(pass-if "neoteric expression"
- (let ((sexp (with-read-options '(curly-infix positions)
+ (let ((sexp (with-read-options '(curly-infix)
(lambda ()
(read-string " { f(x) }")))))
(and (equal? (source-property sexp 'line) 0)
diff --git a/test-suite/tests/srfi-119.test b/test-suite/tests/srfi-119.test
index 5390a25b3..f52f9d8bc 100644
--- a/test-suite/tests/srfi-119.test
+++ b/test-suite/tests/srfi-119.test
@@ -1,6 +1,6 @@
;;;; srfi-119.test --- Test suite for Guile's SRFI-119 reader. -*- scheme -*-
;;;;
-;;;; Copyright (C) 2023 Free Software Foundation, Inc.
+;;;; Copyright (C) 2023, 2025 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
@@ -20,20 +20,12 @@
#:use-module (test-suite lib)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26) ;; cut
+ #:use-module (ice-9 source-properties)
#:use-module (language wisp))
(define (read-string s)
(with-input-from-string s read))
-(define (with-read-options opts thunk)
- (let ((saved-options (read-options)))
- (dynamic-wind
- (lambda ()
- (read-options opts))
- thunk
- (lambda ()
- (read-options saved-options)))))
-
(define (wisp->list str)
(wisp-scheme-read-string str))
@@ -97,14 +89,18 @@ _ display \"hello\n\"
(pass-if-equal '((1 . 2)(3 4 (5 . 6)))
(wisp->list "1 . 2\n3 4\n 5 . 6")))
+(define (source-line props)
+ (or (assq 'line props) (error "expected a line" props)))
+
(with-test-prefix "wisp-source-properties"
;; has properties
(pass-if (every pair? (map source-properties (wisp->list "1 . 2\n3 4\n 5 . 6"))))
(pass-if (every pair? (map source-properties (wisp->list "1 2\n3 4\n 5 6"))))
;; has the same properties
(pass-if-equal
- (map source-properties (scheme->list "(1 . 2)\n(3 4\n (5 . 6))\n(1 4)\n\n(7 8)"))
- (map (cut cons '(filename . #f) <>)
+ (map source-line
+ (map source-properties (scheme->list "(1 . 2)\n(3 4\n (5 . 6))\n(1 4)\n\n(7 8)")))
+ (map source-line
(map source-properties (wisp->list "1 . 2\n3 4\n 5 . 6\n1 4\n\n7 8")))))
(with-test-prefix "btest"
diff --git a/test-suite/tests/srfi-69.test b/test-suite/tests/srfi-69.test
index e99b76c6d..f9f6c3f33 100644
--- a/test-suite/tests/srfi-69.test
+++ b/test-suite/tests/srfi-69.test
@@ -1,6 +1,6 @@
;;;; srfi-69.test --- Test suite for SRFI 69 -*- scheme -*-
;;;;
-;;;; Copyright (C) 2007 Free Software Foundation, Inc.
+;;;; Copyright (C) 2007, 2025 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
@@ -51,6 +51,8 @@ case-insensitive strings to `equal?'-tested values."
'(("xy" . 42) ("abc" . 54) ("qqq" . 100))
(hash-table->alist ht)))))
+ ;; FIXME: Either revive or deprecate.
+ #;
(pass-if-exception "Bad weakness arg to mht signals an error"
'(misc-error . "^Invalid weak hash table type")
(make-hash-table equal? hash #:weak 'key-and-value))
@@ -101,6 +103,8 @@ case-insensitive strings to `equal?'-tested values."
(and (= 1 (hash-table-size ht))
(lset= equal? '((b . 53)) (hash-table->alist ht)))))
+ ;; FIXME: Either revive or deprecate.
+ #;
(pass-if "can use all arguments, including size"
(hash-table? (make-hash-table equal? hash #:weak 'key 31)))
diff --git a/test-suite/tests/syntax.test b/test-suite/tests/syntax.test
index 4872866ab..b5b1088e0 100644
--- a/test-suite/tests/syntax.test
+++ b/test-suite/tests/syntax.test
@@ -1,7 +1,7 @@
;;;; syntax.test --- test suite for Guile's syntactic forms -*- scheme -*-
;;;;
;;;; Copyright (C) 2001, 2003, 2004, 2005, 2006, 2009, 2010,
-;;;; 2011, 2012, 2013, 2014, 2021, 2024 Free Software Foundation, Inc.
+;;;; 2011, 2012, 2013, 2014, 2021, 2024, 2025 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
@@ -119,7 +119,7 @@
(eval (call-with-input-string "\n (let foo bar)"
(lambda (port)
(set-port-filename! port "example.scm")
- (read port)))
+ (read-syntax port)))
(interaction-environment)))
(lambda (key proc message properties form subform . rest)
properties)))
diff --git a/test-suite/tests/tree-il.test b/test-suite/tests/tree-il.test
index dd2e707b2..2ec41864a 100644
--- a/test-suite/tests/tree-il.test
+++ b/test-suite/tests/tree-il.test
@@ -1,7 +1,7 @@
;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*-
;;;; Andy Wingo <wingo@pobox.com> --- May 2009
;;;;
-;;;; Copyright (C) 2009-2014,2018-2021,2023 Free Software Foundation, Inc.
+;;;; Copyright (C) 2009-2014,2018-2021,2023,2025 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
@@ -442,48 +442,44 @@
#:opts %opts-w-unused-module))))
(pass-if "definitely unused"
- (let* ((defmod '(define-module (foo)
- #:use-module (ice-9 vlist)
- #:use-module (ice-9 popen)
- #:export (proc)))
- (w (call-with-warnings
+ (match (call-with-input-string
+ "(begin
+ (define-module (foo)
+ #:use-module (ice-9 vlist)
+ #:use-module (ice-9 popen)
+ #:export (proc))
+ (define (frob x)
+ (vlist-cons x vlist-null)))"
+ (lambda (port)
+ (set-port-filename! port "foo.scm")
+ (call-with-warnings
(lambda ()
- (set-source-properties! defmod
- '((filename . "foo.scm")
- (line . 0)
- (column . 0)))
- (compile `(begin
- ,defmod
- (define (frob x)
- (vlist-cons x vlist-null)))
- #:env (make-fresh-user-module)
- #:opts %opts-w-unused-module)))))
- (and (= (length w) 1)
- (string-prefix? "foo.scm:1:0" (car w))
- (number? (string-contains (car w)
- "unused module (ice-9 popen)")))))
+ (read-and-compile port
+ #:env (make-fresh-user-module)
+ #:opts %opts-w-unused-module)))))
+ ((w)
+ (and (string-prefix? "foo.scm:2:18" w)
+ (number? (string-contains w "unused module (ice-9 popen)"))))
+ (warnings #f)))
(pass-if "definitely unused, use-modules"
- (let* ((usemod '(use-modules (rnrs bytevectors)
- (ice-9 q)))
- (w (call-with-warnings
+ (match (call-with-input-string
+ "(begin
+ (use-modules (rnrs bytevectors) (ice-9 q))
+ (define (square x)
+ (* x x)))"
+ (lambda (port)
+ (set-port-filename! port "bar.scm")
+ (call-with-warnings
(lambda ()
- (set-source-properties! usemod
- '((filename . "bar.scm")
- (line . 5)
- (column . 0)))
- (compile `(begin
- ,usemod
- (define (square x)
- (* x x)))
- #:env (make-fresh-user-module)
- #:opts %opts-w-unused-module)))))
- (and (= (length w) 2)
- (string-prefix? "bar.scm:6:0" (car w))
- (number? (string-contains (car w)
- "unused module (rnrs bytevectors)"))
- (number? (string-contains (cadr w)
- "unused module (ice-9 q)")))))
+ (read-and-compile port
+ #:env (make-fresh-user-module)
+ #:opts %opts-w-unused-module)))))
+ ((w1 w2)
+ (and (string-prefix? "bar.scm:2:18" w1)
+ (number? (string-contains w1 "unused module (rnrs bytevectors)"))
+ (number? (string-contains w2 "unused module (ice-9 q)"))))
+ (warnings #f)))
(pass-if "definitely unused, local binding shadows imported one"
(let ((w (call-with-warnings
diff --git a/test-suite/tests/types.test b/test-suite/tests/types.test
index 778aaa6bd..eeede1308 100644
--- a/test-suite/tests/types.test
+++ b/test-suite/tests/types.test
@@ -22,6 +22,7 @@
#:use-module (rnrs io ports)
#:use-module (ice-9 match)
#:use-module (ice-9 regex)
+ #:use-module (ice-9 weak-tables)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-9)
#:use-module (system foreign)
@@ -100,9 +101,6 @@
((open-input-string "hello") port (? inferior-object?))
((lambda () #t) program _)
((make-variable 'foo) variable _)
- ((make-weak-key-hash-table) weak-table _)
- ((make-weak-value-hash-table) weak-table _)
- ((make-doubly-weak-hash-table) weak-table _)
(#2((1 2 3) (4 5 6)) array _)
(#*00000110 bitvector _)
((expt 2 70) bignum _)
diff --git a/test-suite/tests/weaks.test b/test-suite/tests/weaks.test
index 21c8ddcc4..0541208ae 100644
--- a/test-suite/tests/weaks.test
+++ b/test-suite/tests/weaks.test
@@ -1,5 +1,5 @@
;;;; weaks.test --- tests guile's weaks -*- scheme -*-
-;;;; Copyright (C) 1999, 2001, 2003, 2006, 2009, 2010, 2011, 2012, 2014
+;;;; Copyright (C) 1999, 2001, 2003, 2006, 2009, 2010, 2011, 2012, 2014, 2025
;;;; Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
@@ -37,6 +37,7 @@
(define-module (test-weaks)
#:use-module (test-suite lib)
#:use-module (ice-9 weak-vector)
+ #:use-module (ice-9 weak-tables)
#:use-module (srfi srfi-1)
#:use-module (srfi srfi-26))
@@ -129,7 +130,7 @@
;;;
-;;; Weak hash tables & weak alist vectors.
+;;; Weak hash tables.
;;;
(define (valid? value initial-value)
@@ -139,23 +140,23 @@
(or (not value)
(equal? value initial-value)))
- (let ((x (make-weak-key-hash-table 17))
- (y (make-weak-value-hash-table 17))
- (z (make-doubly-weak-hash-table 17))
+(let ((x (make-weak-key-hash-table #:hash hash #:equal? equal?))
+ (y (make-weak-value-hash-table #:hash hash #:equal? equal?))
+ (z (make-doubly-weak-hash-table #:hash hash #:equal? equal?))
(test-key "foo")
(test-value "bar"))
(with-test-prefix
"weak-hash"
(pass-if "lives"
(begin
- (hash-set! x test-key test-value)
- (hash-set! y test-key test-value)
- (hash-set! z test-key test-value)
+ (weak-key-hash-table-set! x test-key test-value)
+ (weak-value-hash-table-set! y test-key test-value)
+ (doubly-weak-hash-table-set! z test-key test-value)
(gc)
(gc)
- (and (hash-ref x test-key)
- (hash-ref y test-key)
- (hash-ref z test-key)
+ (and (weak-key-hash-table-ref x test-key)
+ (weak-value-hash-table-ref y test-key)
+ (doubly-weak-hash-table-ref z test-key)
#t)))
;; In the tests below we use `string-copy' to avoid the risk of
@@ -163,117 +164,105 @@
(pass-if "weak-key dies"
(begin
- (hash-set! x (string-copy "this") "is")
- (hash-set! x (string-copy "a") "test")
- (hash-set! x (string-copy "of") "the")
- (hash-set! x (string-copy "emergency") "weak")
- (hash-set! x (string-copy "key") "hash system")
+ (weak-key-hash-table-set! x (string-copy "this") "is")
+ (weak-key-hash-table-set! x (string-copy "a") "test")
+ (weak-key-hash-table-set! x (string-copy "of") "the")
+ (weak-key-hash-table-set! x (string-copy "emergency") "weak")
+ (weak-key-hash-table-set! x (string-copy "key") "hash system")
(gc)
- (let ((values (map (cut hash-ref x <>)
+ (let ((values (map (cut weak-key-hash-table-ref x <>)
'("this" "a" "of" "emergency" "key"))))
(and (every valid? values
'("is" "test" "the" "weak" "hash system"))
(any not values)
- (hash-ref x test-key)
+ (weak-key-hash-table-ref x test-key)
#t))))
(pass-if "weak-value dies"
(begin
- (hash-set! y "this" (string-copy "is"))
- (hash-set! y "a" (string-copy "test"))
- (hash-set! y "of" (string-copy "the"))
- (hash-set! y "emergency" (string-copy "weak"))
- (hash-set! y "value" (string-copy "hash system"))
+ (weak-value-hash-table-set! y "this" (string-copy "is"))
+ (weak-value-hash-table-set! y "a" (string-copy "test"))
+ (weak-value-hash-table-set! y "of" (string-copy "the"))
+ (weak-value-hash-table-set! y "emergency" (string-copy "weak"))
+ (weak-value-hash-table-set! y "value" (string-copy "hash system"))
(gc)
- (let ((values (map (cut hash-ref y <>)
+ (let ((values (map (cut weak-value-hash-table-ref y <>)
'("this" "a" "of" "emergency" "key"))))
(and (every valid? values
'("is" "test" "the" "weak" "hash system"))
(any not values)
- (hash-ref y test-key)
+ (weak-value-hash-table-ref y test-key)
#t))))
(pass-if "doubly-weak dies"
(begin
- (hash-set! z (string-copy "this") (string-copy "is"))
- (hash-set! z "a" (string-copy "test"))
- (hash-set! z (string-copy "of") "the")
- (hash-set! z "emergency" (string-copy "weak"))
- (hash-set! z (string-copy "all") (string-copy "hash system"))
+ (doubly-weak-hash-table-set! z (string-copy "this") (string-copy "is"))
+ (doubly-weak-hash-table-set! z "a" (string-copy "test"))
+ (doubly-weak-hash-table-set! z (string-copy "of") "the")
+ (doubly-weak-hash-table-set! z "emergency" (string-copy "weak"))
+ (doubly-weak-hash-table-set! z (string-copy "all") (string-copy "hash system"))
(gc)
- (let ((values (map (cut hash-ref z <>)
+ (let ((values (map (cut doubly-weak-hash-table-ref z <>)
'("this" "a" "of" "emergency" "key"))))
(and (every valid? values
'("is" "test" "the" "weak" "hash system"))
(any not values)
- (hash-ref z test-key)
+ (doubly-weak-hash-table-ref z test-key)
#t))))
- (pass-if "hash-set!, weak val, im -> im"
- (let ((t (make-weak-value-hash-table)))
- (hash-set! t "foo" 1)
- (hash-set! t "foo" 2)
- (equal? (hash-ref t "foo") 2)))
-
- (pass-if "hash-set!, weak val, im -> nim"
- (let ((t (make-weak-value-hash-table)))
- (hash-set! t "foo" 1)
- (hash-set! t "foo" "baz")
- (equal? (hash-ref t "foo") "baz")))
-
- (pass-if "hash-set!, weak val, nim -> nim"
- (let ((t (make-weak-value-hash-table)))
- (hash-set! t "foo" "bar")
- (hash-set! t "foo" "baz")
- (equal? (hash-ref t "foo") "baz")))
-
- (pass-if "hash-set!, weak val, nim -> im"
- (let ((t (make-weak-value-hash-table)))
- (hash-set! t "foo" "bar")
- (hash-set! t "foo" 1)
- (equal? (hash-ref t "foo") 1)))
-
- (pass-if "hash-set!, weak key, returns value"
- (let ((t (make-weak-value-hash-table))
- (val (string #\f #\o #\o)))
- (eq? (hashq-set! t "bar" val)
- (hashv-set! t "bar" val)
- (hash-set! t "bar" val)
- val)))
+ (pass-if "weak-value-hash-table-set!, weak val, im -> im"
+ (let ((t (make-weak-value-hash-table #:equal? equal? #:hash hash)))
+ (weak-value-hash-table-set! t "foo" 1)
+ (weak-value-hash-table-set! t "foo" 2)
+ (equal? (weak-value-hash-table-ref t "foo") 2)))
+
+ (pass-if "weak-value-hash-table-set!, weak val, im -> nim"
+ (let ((t (make-weak-value-hash-table #:equal? equal? #:hash hash)))
+ (weak-value-hash-table-set! t "foo" 1)
+ (weak-value-hash-table-set! t "foo" "baz")
+ (equal? (weak-value-hash-table-ref t "foo") "baz")))
+
+ (pass-if "weak-value-hash-table-set!, weak val, nim -> nim"
+ (let ((t (make-weak-value-hash-table #:equal? equal? #:hash hash)))
+ (weak-value-hash-table-set! t "foo" "bar")
+ (weak-value-hash-table-set! t "foo" "baz")
+ (equal? (weak-value-hash-table-ref t "foo") "baz")))
+
+ (pass-if "weak-value-hash-table-set!, weak val, nim -> im"
+ (let ((t (make-weak-value-hash-table #:equal? equal? #:hash hash)))
+ (weak-value-hash-table-set! t "foo" "bar")
+ (weak-value-hash-table-set! t "foo" 1)
+ (equal? (weak-value-hash-table-ref t "foo") 1)))
(pass-if "assoc can do anything"
;; Until 1.9.12, as hash table's custom ASSOC procedure was
;; called with the GC lock alloc held, which imposed severe
;; restrictions on what it could do (bug #29616). This test
;; makes sure this is no longer the case.
- (let ((h (make-doubly-weak-hash-table 2))
+ (let ((h (make-doubly-weak-hash-table
+ #:initial-size 2
+ #:hash string-hash-ci
+ #:equal? (lambda (a b)
+ (make-list 123) ;; this should be possible
+ (gc) ;; this too
+ (string-ci=? a b))))
(c 123)
(k "GNU"))
- (define (assoc-ci key bucket)
- (make-list 123) ;; this should be possible
- (gc) ;; this too
- (find (lambda (p)
- (string-ci=? key (car p)))
- bucket))
-
- (hashx-set! string-hash-ci assoc-ci h
- (string-copy "hello") (string-copy "world"))
- (hashx-set! string-hash-ci assoc-ci h
- k "Guile")
+ (doubly-weak-hash-table-set! h (string-copy "hello")
+ (string-copy "world"))
+ (doubly-weak-hash-table-set! h k "Guile")
(and (every (cut valid? <> "Guile")
(unfold (cut >= <> c)
(lambda (_)
- (hashx-ref string-hash-ci assoc-ci
- h "gnu"))
+ (doubly-weak-hash-table-ref h "gnu"))
1+
0))
(every (cut valid? <> "world")
(unfold (cut >= <> c)
(lambda (_)
- (hashx-ref string-hash-ci assoc-ci
- h "HELLO"))
+ (doubly-weak-hash-table-ref h "HELLO"))
1+
0))
#t)))))