diff options
Diffstat (limited to 'test-suite')
-rw-r--r-- | test-suite/tests/compiler.test | 25 | ||||
-rw-r--r-- | test-suite/tests/coverage.test | 5 | ||||
-rw-r--r-- | test-suite/tests/elisp-reader.test | 10 | ||||
-rw-r--r-- | test-suite/tests/ephemerons.test | 46 | ||||
-rw-r--r-- | test-suite/tests/eval-string.test | 18 | ||||
-rw-r--r-- | test-suite/tests/gc.test | 5 | ||||
-rw-r--r-- | test-suite/tests/hash.test | 10 | ||||
-rw-r--r-- | test-suite/tests/modules.test | 43 | ||||
-rw-r--r-- | test-suite/tests/reader.test | 23 | ||||
-rw-r--r-- | test-suite/tests/srcprop.test | 10 | ||||
-rw-r--r-- | test-suite/tests/srfi-105.test | 39 | ||||
-rw-r--r-- | test-suite/tests/srfi-119.test | 20 | ||||
-rw-r--r-- | test-suite/tests/srfi-69.test | 6 | ||||
-rw-r--r-- | test-suite/tests/syntax.test | 4 | ||||
-rw-r--r-- | test-suite/tests/tree-il.test | 74 | ||||
-rw-r--r-- | test-suite/tests/types.test | 4 | ||||
-rw-r--r-- | test-suite/tests/weaks.test | 147 |
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))))) |