mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-03 18:50:19 +02:00
Code Activity

Remove use of source properties in psyntax

Browse source 
* module/ice-9/psyntax.scm (source-annotation): Only get source info
from syntax objects.
(strip): Don't attach source info.
(macroexpand): Don't proxy source info in that isn't in a syntax object.
(datum->syntax): Don't proxy source info from source-properties.
* test-suite/tests/compiler.test ("psyntax"):
* test-suite/tests/coverage.test (code):
* test-suite/tests/eval-string.test ("basic"):
* test-suite/tests/syntax.test ("expressions"):
* test-suite/tests/tree-il.test ("warnings"): Update tests that attach
source properties to use read-and-compile, or read-syntax.
This commit is contained in:
Andy Wingo 2025-05-09 14:32:29 +02:00
parent 05dd829ad3
commit f399f36d37
7 changed files with 127 additions and 182 deletions
Download patch file Download diff file Expand all files Collapse all files

146
module/ice-9/psyntax-pp.scm
View file

@ -177,11 +177,7 @@
(if (null? v) body-exp (fk))))) (if (null? v) body-exp (fk)))))
(gen-lexical (lambda (id) (module-gensym (symbol->string id)))) (gen-lexical (lambda (id) (module-gensym (symbol->string id))))
(no-source #f) (no-source #f)
(datum-sourcev (source-annotation (lambda (x) (and (syntax? x) (syntax-sourcev x))))
(lambda (datum)
(let ((props (source-properties datum)))
(and (pair? props) (vector (assq-ref props 'filename) (assq-ref props 'line) (assq-ref props 'column))))))
(source-annotation (lambda (x) (if (syntax? x) (syntax-sourcev x) (datum-sourcev x))))
(binding-type (lambda (x) (car x))) (binding-type (lambda (x) (car x)))
(binding-value (lambda (x) (cdr x))) (binding-value (lambda (x) (cdr x)))
(null-env '()) (null-env '())
@ -1141,11 +1137,11 @@
(source-wrap e w (wrap-subst w) mod) (source-wrap e w (wrap-subst w) mod)
x)) x))
(else (decorate-source x)))))) (else (decorate-source x))))))
(let* ((t-680b775fb37a463-c45 transformer-environment) (let* ((t-680b775fb37a463-c32 transformer-environment)
(t-680b775fb37a463-c46 (lambda (k) (k e r w s rib mod)))) (t-680b775fb37a463-c33 (lambda (k) (k e r w s rib mod))))
(with-fluid* (with-fluid*
t-680b775fb37a463-c45 t-680b775fb37a463-c32
t-680b775fb37a463-c46 t-680b775fb37a463-c33
(lambda () (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod)) (new-mark)))))))) (lambda () (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod)) (new-mark))))))))
(expand-body (expand-body
(lambda (body outer-form r w mod) (lambda (body outer-form r w mod)
@ -1676,11 +1672,11 @@
s s
mod mod
get-formals get-formals
(map (lambda (tmp-680b775fb37a463-ece (map (lambda (tmp-680b775fb37a463-ebb
tmp-680b775fb37a463-ecd tmp-680b775fb37a463-eba
tmp-680b775fb37a463-ecc) tmp-680b775fb37a463-eb9)
(cons tmp-680b775fb37a463-ecc (cons tmp-680b775fb37a463-eb9
(cons tmp-680b775fb37a463-ecd tmp-680b775fb37a463-ece))) (cons tmp-680b775fb37a463-eba tmp-680b775fb37a463-ebb)))
e2* e2*
e1* e1*
args*))) args*)))
@ -1691,17 +1687,11 @@
tmp-1) tmp-1)
(syntax-violation #f "source expression failed to match any pattern" tmp)))))))) (syntax-violation #f "source expression failed to match any pattern" tmp))))))))
(strip (lambda (x) (strip (lambda (x)
(letrec* ((annotate (cond
(lambda (proc datum) ((syntax? x) (strip (syntax-expression x)))
(let ((s (proc x))) ((pair? x) (cons (strip (car x)) (strip (cdr x))))
(if (and s (supports-source-properties? datum)) ((vector? x) (list->vector (strip (vector->list x))))
(set-source-properties! datum (sourcev->alist s))) (else x))))
datum))))
(cond
((syntax? x) (annotate syntax-sourcev (strip (syntax-expression x))))
((pair? x) (cons (strip (car x)) (strip (cdr x))))
((vector? x) (list->vector (strip (vector->list x))))
(else x)))))
(gen-var (lambda (id) (let ((id (if (syntax? id) (syntax-expression id) id))) (gen-lexical id)))) (gen-var (lambda (id) (let ((id (if (syntax? id) (syntax-expression id) id))) (gen-lexical id))))
(lambda-var-list (lambda-var-list
(lambda (vars) (lambda (vars)
@ -1964,9 +1954,11 @@
(apply (lambda (docstring args e1 e2) (apply (lambda (docstring args e1 e2)
(build-it (build-it
(list (cons 'documentation (syntax->datum docstring))) (list (cons 'documentation (syntax->datum docstring)))
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-112b
tmp-680b775fb37a463-112a
tmp-680b775fb37a463)
(cons tmp-680b775fb37a463 (cons tmp-680b775fb37a463
(cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2))) (cons tmp-680b775fb37a463-112a tmp-680b775fb37a463-112b)))
e2 e2
e1 e1
args))) args)))
@ -1984,8 +1976,9 @@
(apply (lambda (args e1 e2) (apply (lambda (args e1 e2)
(build-it (build-it
'() '()
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-114b tmp-680b775fb37a463-114a tmp-680b775fb37a463)
(cons tmp-680b775fb37a463 (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2))) (cons tmp-680b775fb37a463
(cons tmp-680b775fb37a463-114a tmp-680b775fb37a463-114b)))
e2 e2
e1 e1
args))) args)))
@ -1995,11 +1988,9 @@
(apply (lambda (docstring args e1 e2) (apply (lambda (docstring args e1 e2)
(build-it (build-it
(list (cons 'documentation (syntax->datum docstring))) (list (cons 'documentation (syntax->datum docstring)))
(map (lambda (tmp-680b775fb37a463-117f (map (lambda (tmp-680b775fb37a463-1 tmp-680b775fb37a463 tmp-680b775fb37a463-115f)
tmp-680b775fb37a463-117e (cons tmp-680b775fb37a463-115f
tmp-680b775fb37a463-117d) (cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)))
(cons tmp-680b775fb37a463-117d
(cons tmp-680b775fb37a463-117e tmp-680b775fb37a463-117f)))
e2 e2
e1 e1
args))) args)))
@ -2449,27 +2440,7 @@
(global-extend 'core 'syntax-case expand-syntax-case) (global-extend 'core 'syntax-case expand-syntax-case)
(set! macroexpand (set! macroexpand
(lambda* (x #:optional (m 'e) (esew '(eval))) (lambda* (x #:optional (m 'e) (esew '(eval)))
(letrec* ((unstrip (expand-top-sequence (list x) null-env top-wrap #f m esew (cons 'hygiene (module-name (current-module))))))
(lambda (x)
(letrec* ((annotate
(lambda (result)
(let ((props (source-properties x)))
(if (pair? props) (datum->syntax #f result #:source props) result)))))
(cond
((pair? x) (annotate (cons (unstrip (car x)) (unstrip (cdr x)))))
((vector? x)
(let ((v (make-vector (vector-length x))))
(annotate (list->vector (map unstrip (vector->list x))))))
((syntax? x) x)
(else (annotate x)))))))
(expand-top-sequence
(list (unstrip x))
null-env
top-wrap
#f
m
esew
(cons 'hygiene (module-name (current-module)))))))
(set! identifier? (lambda (x) (nonsymbol-id? x))) (set! identifier? (lambda (x) (nonsymbol-id? x)))
(set! datum->syntax (set! datum->syntax
(lambda* (id datum #:key (source #f #:source)) (lambda* (id datum #:key (source #f #:source))
@ -2482,7 +2453,7 @@
(if id (syntax-wrap id) empty-wrap) (if id (syntax-wrap id) empty-wrap)
(and id (syntax-module id)) (and id (syntax-module id))
(cond (cond
((not source) (props->sourcev (source-properties datum))) ((not source) #f)
((and (list? source) (and-map pair? source)) (props->sourcev source)) ((and (list? source) (and-map pair? source)) (props->sourcev source))
((and (vector? source) (= 3 (vector-length source))) source) ((and (vector? source) (= 3 (vector-length source))) source)
(else (syntax-sourcev source))))))) (else (syntax-sourcev source)))))))
@ -2822,9 +2793,9 @@
#f #f
k k
'() '()
(map (lambda (tmp-680b775fb37a463-145d tmp-680b775fb37a463-145c tmp-680b775fb37a463-145b) (map (lambda (tmp-680b775fb37a463-143f tmp-680b775fb37a463-143e tmp-680b775fb37a463-143d)
(list (cons tmp-680b775fb37a463-145b tmp-680b775fb37a463-145c) (list (cons tmp-680b775fb37a463-143d tmp-680b775fb37a463-143e)
tmp-680b775fb37a463-145d)) tmp-680b775fb37a463-143f))
template template
pattern pattern
keyword))) keyword)))
@ -2852,11 +2823,9 @@
dots dots
k k
'() '()
(map (lambda (tmp-680b775fb37a463-148f (map (lambda (tmp-680b775fb37a463-1 tmp-680b775fb37a463 tmp-680b775fb37a463-146f)
tmp-680b775fb37a463-148e (list (cons tmp-680b775fb37a463-146f tmp-680b775fb37a463)
tmp-680b775fb37a463-148d) tmp-680b775fb37a463-1))
(list (cons tmp-680b775fb37a463-148d tmp-680b775fb37a463-148e)
tmp-680b775fb37a463-148f))
template template
pattern pattern
keyword))) keyword)))
@ -2872,11 +2841,11 @@
dots dots
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463-14ae (map (lambda (tmp-680b775fb37a463
tmp-680b775fb37a463-14ad tmp-680b775fb37a463-148f
tmp-680b775fb37a463-14ac) tmp-680b775fb37a463-148e)
(list (cons tmp-680b775fb37a463-14ac tmp-680b775fb37a463-14ad) (list (cons tmp-680b775fb37a463-148e tmp-680b775fb37a463-148f)
tmp-680b775fb37a463-14ae)) tmp-680b775fb37a463))
template template
pattern pattern
keyword))) keyword)))
@ -3004,9 +2973,9 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasilist* (quasilist*
(map (lambda (tmp-680b775fb37a463-155b) (map (lambda (tmp-680b775fb37a463-153d)
(list "value" (list "value"
tmp-680b775fb37a463-155b)) tmp-680b775fb37a463-153d))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -3091,8 +3060,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463-157b) (map (lambda (tmp-680b775fb37a463-155d)
(list "value" tmp-680b775fb37a463-157b)) (list "value" tmp-680b775fb37a463-155d))
p) p)
(vquasi q lev)) (vquasi q lev))
(quasicons (quasicons
@ -3174,8 +3143,8 @@
(let ((tmp-1 ls)) (let ((tmp-1 ls))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-15c4) (apply (lambda (t-680b775fb37a463-15a6)
(cons "vector" t-680b775fb37a463-15c4)) (cons "vector" t-680b775fb37a463-15a6))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3185,8 +3154,8 @@
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any))))
(if tmp-1 (if tmp-1
(apply (lambda (y) (apply (lambda (y)
(k (map (lambda (tmp-680b775fb37a463-15d0) (k (map (lambda (tmp-680b775fb37a463-15b2)
(list "quote" tmp-680b775fb37a463-15d0)) (list "quote" tmp-680b775fb37a463-15b2))
y))) y)))
tmp-1) tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any))))
@ -3197,8 +3166,8 @@
(apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1) (apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1)
(let ((else tmp)) (let ((else tmp))
(let ((tmp x)) (let ((tmp x))
(let ((t-680b775fb37a463-15df tmp)) (let ((t-680b775fb37a463-15c1 tmp))
(list "list->vector" t-680b775fb37a463-15df))))))))))))))))) (list "list->vector" t-680b775fb37a463-15c1)))))))))))))))))
(emit (lambda (x) (emit (lambda (x)
(let ((tmp x)) (let ((tmp x))
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any))))
@ -3210,9 +3179,9 @@
(let ((tmp-1 (map emit x))) (let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-15ee) (apply (lambda (t-680b775fb37a463-15d0)
(cons (make-syntax 'list '((top)) '(hygiene guile)) (cons (make-syntax 'list '((top)) '(hygiene guile))
t-680b775fb37a463-15ee)) t-680b775fb37a463-15d0))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3228,13 +3197,14 @@
(let ((tmp-1 (list (emit (car x*)) (f (cdr x*))))) (let ((tmp-1 (list (emit (car x*)) (f (cdr x*)))))
(let ((tmp ($sc-dispatch tmp-1 '(any any)))) (let ((tmp ($sc-dispatch tmp-1 '(any any))))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-1 t-680b775fb37a463) (apply (lambda (t-680b775fb37a463-15e4
t-680b775fb37a463-15e3)
(list (make-syntax (list (make-syntax
'cons 'cons
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463-1 t-680b775fb37a463-15e4
t-680b775fb37a463)) t-680b775fb37a463-15e3))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3247,12 +3217,12 @@
(let ((tmp-1 (map emit x))) (let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-160e) (apply (lambda (t-680b775fb37a463-15f0)
(cons (make-syntax (cons (make-syntax
'append 'append
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463-160e)) t-680b775fb37a463-15f0))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3265,12 +3235,12 @@
(let ((tmp-1 (map emit x))) (let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-161a) (apply (lambda (t-680b775fb37a463-15fc)
(cons (make-syntax (cons (make-syntax
'vector 'vector
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463-161a)) t-680b775fb37a463-15fc))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f

39
module/ice-9/psyntax.scm
View file

@ -1,6 +1,6 @@
;;;; -*-scheme-*- ;;;; -*-scheme-*-
;;;; ;;;;
;;;; Copyright (C) 1997-1998,2000-2003,2005-2006,2008-2013,2015-2022,2024 ;;;; Copyright (C) 1997-1998,2000-2003,2005-2006,2008-2013,2015-2022,2024,2025
;;;; Free Software Foundation, Inc. ;;;; Free Software Foundation, Inc.
;;;; ;;;;
;;;; This library is free software: you can redistribute it and/or modify ;;;; This library is free software: you can redistribute it and/or modify
@ -303,17 +303,8 @@
(define no-source #f) (define no-source #f)
(define (datum-sourcev datum)
(let ((props (source-properties datum)))
(and (pair? props)
(vector (assq-ref props 'filename)
(assq-ref props 'line)
(assq-ref props 'column)))))
(define (source-annotation x) (define (source-annotation x)
(if (syntax? x) (and (syntax? x) (syntax-sourcev x)))
(syntax-sourcev x)
(datum-sourcev x)))
(define-syntax-rule (arg-check pred? e who) (define-syntax-rule (arg-check pred? e who)
(let ((x e)) (let ((x e))
@ -1863,14 +1854,9 @@
;; strips syntax objects, recursively. ;; strips syntax objects, recursively.
(define (strip x) (define (strip x)
(define (annotate proc datum)
(let ((s (proc x)))
(when (and s (supports-source-properties? datum))
(set-source-properties! datum (sourcev->alist s)))
datum))
(cond (cond
((syntax? x) ((syntax? x)
(annotate syntax-sourcev (strip (syntax-expression x)))) (strip (syntax-expression x)))
((pair? x) ((pair? x)
(cons (strip (car x)) (strip (cdr x)))) (cons (strip (car x)) (strip (cdr x))))
((vector? x) ((vector? x)
@ -2592,21 +2578,7 @@
;; expanded, and the expanded definitions are also residualized into ;; expanded, and the expanded definitions are also residualized into
;; the object file if we are compiling a file. ;; the object file if we are compiling a file.
(define*/override (macroexpand x #:optional (m 'e) (esew '(eval))) (define*/override (macroexpand x #:optional (m 'e) (esew '(eval)))
(define (unstrip x) (expand-top-sequence (list x) null-env top-wrap #f m esew
(define (annotate result)
(let ((props (source-properties x)))
(if (pair? props)
(datum->syntax #f result #:source props)
result)))
(cond
((pair? x)
(annotate (cons (unstrip (car x)) (unstrip (cdr x)))))
((vector? x)
(let ((v (make-vector (vector-length x))))
(annotate (list->vector (map unstrip (vector->list x))))))
((syntax? x) x)
(else (annotate x))))
(expand-top-sequence (list (unstrip x)) null-env top-wrap #f m esew
(cons 'hygiene (module-name (current-module))))) (cons 'hygiene (module-name (current-module)))))
(define/override (identifier? x) (define/override (identifier? x)
@ -2626,8 +2598,7 @@
(syntax-module id) (syntax-module id)
#f) #f)
(cond (cond
((not source) ((not source) #f)
(props->sourcev (source-properties datum)))
((and (list? source) (and-map pair? source)) ((and (list? source) (and-map pair? source))
(props->sourcev source)) (props->sourcev source))
((and (vector? source) (= 3 (vector-length source))) ((and (vector? source) (= 3 (vector-length source)))

23
test-suite/tests/compiler.test
View file

@ -1,5 +1,5 @@
;;;; compiler.test --- tests for the compiler -*- scheme -*- ;;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -76,13 +76,10 @@
(pass-if-equal "syntax-source with read-hash-extend" (pass-if-equal "syntax-source with read-hash-extend"
'((filename . "sample.scm") (line . 2) (column . 5)) '((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>
(with-fluids ((%read-hash-procedures (with-fluids ((%read-hash-procedures
(fluid-ref %read-hash-procedures))) (fluid-ref %read-hash-procedures)))
(read-hash-extend #\~ (lambda (chr port) (read-hash-extend #\~ (lambda (chr port)
(list 'magic (read port)))) (list 'magic (read-syntax port))))
(tree-il-src (tree-il-src
(car (car
(call-args (call-args
@ -156,20 +153,26 @@
;; with IP 0 of a VM program, which corresponds to the entry point. See ;; with IP 0 of a VM program, which corresponds to the entry point. See
;; also <http://savannah.gnu.org/bugs/?29817> for details. ;; 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" (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)))))) (not (not (memv 0 (map source:addr s))))))
(pass-if "lambda*" (pass-if "lambda*"
(let ((s (program-sources (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)))))) (not (not (memv 0 (map source:addr s))))))
(pass-if "case-lambda" (pass-if "case-lambda"
(let ((s (program-sources (let ((s (program-sources
(compile '(case-lambda (() #t) (compile-string
((y) y) "(case-lambda (() #t)
((y z) (list y z))))))) ((y) y)
((y z) (list y z)))"))))
(not (not (memv 0 (map source:addr s)))))))) (not (not (memv 0 (map source:addr s))))))))
(with-test-prefix "case-lambda" (with-test-prefix "case-lambda"

5
test-suite/tests/coverage.test
View file

@ -1,6 +1,6 @@
;;;; coverage.test --- Code coverage. -*- mode: scheme; coding: utf-8; -*- ;;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -30,8 +30,7 @@
((_ filename snippet) ((_ filename snippet)
(let ((input (open-input-string snippet))) (let ((input (open-input-string snippet)))
(set-port-filename! input filename) (set-port-filename! input filename)
(read-enable 'positions) (compile (read-syntax input))))))
(compile (read input))))))
(define test-procedure (define test-procedure
(compile '(lambda (x) (compile '(lambda (x)

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

@ -1,5 +1,5 @@
;;;; eval-string.test --- tests for (ice-9 eval-string) -*- scheme -*- ;;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -17,7 +17,8 @@
(define-module (test-suite test-eval-string) (define-module (test-suite test-eval-string)
#:use-module (test-suite lib) #: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" (with-test-prefix "basic"
@ -53,7 +54,12 @@
list) list)
'(1 2))) '(1 2)))
(pass-if-equal "source properties" (pass-if-equal "source locations" "test.scm:4:41"
'((filename . "test.scm") (line . 3) (column . 42)) (match (string-split
(source-properties (object->string
(eval-string "'(1 2)" #:file "test.scm" #:line 3 #:column 41)))) (eval-string "(lambda () 42)"
#:file "test.scm" #:line 3 #:column 41
#:compile? #t))
#\space)
(("#<procedure" addr "at" loc "()>")
loc))))

4
test-suite/tests/syntax.test
View file

@ -1,7 +1,7 @@
;;;; syntax.test --- test suite for Guile's syntactic forms -*- scheme -*- ;;;; syntax.test --- test suite for Guile's syntactic forms -*- scheme -*-
;;;; ;;;;
;;;; Copyright (C) 2001, 2003, 2004, 2005, 2006, 2009, 2010, ;;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -119,7 +119,7 @@
(eval (call-with-input-string "\n (let foo bar)" (eval (call-with-input-string "\n (let foo bar)"
(lambda (port) (lambda (port)
(set-port-filename! port "example.scm") (set-port-filename! port "example.scm")
(read port))) (read-syntax port)))
(interaction-environment))) (interaction-environment)))
(lambda (key proc message properties form subform . rest) (lambda (key proc message properties form subform . rest)
properties))) properties)))

74
test-suite/tests/tree-il.test
View file

@ -1,7 +1,7 @@
;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*- ;;;; tree-il.test --- test suite for compiling tree-il -*- scheme -*-
;;;; Andy Wingo <wingo@pobox.com> --- May 2009 ;;;; 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 ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -442,48 +442,44 @@
#:opts %opts-w-unused-module)))) #:opts %opts-w-unused-module))))
(pass-if "definitely unused" (pass-if "definitely unused"
(let* ((defmod '(define-module (foo) (match (call-with-input-string
#:use-module (ice-9 vlist) "(begin
#:use-module (ice-9 popen) (define-module (foo)
#:export (proc))) #:use-module (ice-9 vlist)
(w (call-with-warnings #: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 () (lambda ()
(set-source-properties! defmod (read-and-compile port
'((filename . "foo.scm") #:env (make-fresh-user-module)
(line . 0) #:opts %opts-w-unused-module)))))
(column . 0))) ((w)
(compile `(begin (and (string-prefix? "foo.scm:2:18" w)
,defmod (number? (string-contains w "unused module (ice-9 popen)"))))
(define (frob x) (warnings #f)))
(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)")))))
(pass-if "definitely unused, use-modules" (pass-if "definitely unused, use-modules"
(let* ((usemod '(use-modules (rnrs bytevectors) (match (call-with-input-string
(ice-9 q))) "(begin
(w (call-with-warnings (use-modules (rnrs bytevectors) (ice-9 q))
(define (square x)
(* x x)))"
(lambda (port)
(set-port-filename! port "bar.scm")
(call-with-warnings
(lambda () (lambda ()
(set-source-properties! usemod (read-and-compile port
'((filename . "bar.scm") #:env (make-fresh-user-module)
(line . 5) #:opts %opts-w-unused-module)))))
(column . 0))) ((w1 w2)
(compile `(begin (and (string-prefix? "bar.scm:2:18" w1)
,usemod (number? (string-contains w1 "unused module (rnrs bytevectors)"))
(define (square x) (number? (string-contains w2 "unused module (ice-9 q)"))))
(* x x))) (warnings #f)))
#: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)")))))
(pass-if "definitely unused, local binding shadows imported one" (pass-if "definitely unused, local binding shadows imported one"
(let ((w (call-with-warnings (let ((w (call-with-warnings