wingo pushed a commit to branch wip-whippet
in repository guile.
commit f399f36d373f2587655df8edfa2c2a5d83ff7526
Author: Andy Wingo <wi...@pobox.com>
AuthorDate: Fri May 9 14:32:29 2025 +0200
Remove use of source properties in psyntax
* 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.
---
module/ice-9/psyntax-pp.scm | 146 +++++++++++++++-----------------------
module/ice-9/psyntax.scm | 39 ++--------
test-suite/tests/compiler.test | 23 +++---
test-suite/tests/coverage.test | 5 +-
test-suite/tests/eval-string.test | 18 +++--
test-suite/tests/syntax.test | 4 +-
test-suite/tests/tree-il.test | 74 +++++++++----------
7 files changed, 127 insertions(+), 182 deletions(-)
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index d5b428d8c..63549388b 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -177,11 +177,7 @@
(if (null? v) body-exp (fk)))))
(gen-lexical (lambda (id) (module-gensym (symbol->string id))))
(no-source #f)
- (datum-sourcev
- (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))))
+ (source-annotation (lambda (x) (and (syntax? x) (syntax-sourcev
x))))
(binding-type (lambda (x) (car x)))
(binding-value (lambda (x) (cdr x)))
(null-env '())
@@ -1141,11 +1137,11 @@
(source-wrap e w (wrap-subst w) mod)
x))
(else (decorate-source x))))))
- (let* ((t-680b775fb37a463-c45 transformer-environment)
- (t-680b775fb37a463-c46 (lambda (k) (k e r w s rib
mod))))
+ (let* ((t-680b775fb37a463-c32 transformer-environment)
+ (t-680b775fb37a463-c33 (lambda (k) (k e r w s rib
mod))))
(with-fluid*
- t-680b775fb37a463-c45
- t-680b775fb37a463-c46
+ t-680b775fb37a463-c32
+ t-680b775fb37a463-c33
(lambda () (rebuild-macro-output (p (source-wrap e
(anti-mark w) s mod)) (new-mark))))))))
(expand-body
(lambda (body outer-form r w mod)
@@ -1676,11 +1672,11 @@
s
mod
get-formals
- (map (lambda
(tmp-680b775fb37a463-ece
-
tmp-680b775fb37a463-ecd
-
tmp-680b775fb37a463-ecc)
- (cons
tmp-680b775fb37a463-ecc
- (cons
tmp-680b775fb37a463-ecd tmp-680b775fb37a463-ece)))
+ (map (lambda
(tmp-680b775fb37a463-ebb
+
tmp-680b775fb37a463-eba
+
tmp-680b775fb37a463-eb9)
+ (cons
tmp-680b775fb37a463-eb9
+ (cons
tmp-680b775fb37a463-eba tmp-680b775fb37a463-ebb)))
e2*
e1*
args*)))
@@ -1691,17 +1687,11 @@
tmp-1)
(syntax-violation #f "source expression failed to
match any pattern" tmp))))))))
(strip (lambda (x)
- (letrec* ((annotate
- (lambda (proc datum)
- (let ((s (proc x)))
- (if (and s (supports-source-properties?
datum))
- (set-source-properties! datum
(sourcev->alist s)))
- 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)))))
+ (cond
+ ((syntax? x) (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))))
(lambda-var-list
(lambda (vars)
@@ -1964,9 +1954,11 @@
(apply (lambda (docstring args e1 e2)
(build-it
(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-1 tmp-680b775fb37a463-2)))
+ (cons
tmp-680b775fb37a463-112a tmp-680b775fb37a463-112b)))
e2
e1
args)))
@@ -1984,8 +1976,9 @@
(apply (lambda (args e1 e2)
(build-it
'()
- (map (lambda (tmp-680b775fb37a463-2
tmp-680b775fb37a463-1 tmp-680b775fb37a463)
- (cons tmp-680b775fb37a463 (cons
tmp-680b775fb37a463-1 tmp-680b775fb37a463-2)))
+ (map (lambda (tmp-680b775fb37a463-114b
tmp-680b775fb37a463-114a tmp-680b775fb37a463)
+ (cons tmp-680b775fb37a463
+ (cons tmp-680b775fb37a463-114a
tmp-680b775fb37a463-114b)))
e2
e1
args)))
@@ -1995,11 +1988,9 @@
(apply (lambda (docstring args e1 e2)
(build-it
(list (cons 'documentation
(syntax->datum docstring)))
- (map (lambda (tmp-680b775fb37a463-117f
- tmp-680b775fb37a463-117e
- tmp-680b775fb37a463-117d)
- (cons tmp-680b775fb37a463-117d
- (cons
tmp-680b775fb37a463-117e tmp-680b775fb37a463-117f)))
+ (map (lambda (tmp-680b775fb37a463-1
tmp-680b775fb37a463 tmp-680b775fb37a463-115f)
+ (cons tmp-680b775fb37a463-115f
+ (cons tmp-680b775fb37a463
tmp-680b775fb37a463-1)))
e2
e1
args)))
@@ -2449,27 +2440,7 @@
(global-extend 'core 'syntax-case expand-syntax-case)
(set! macroexpand
(lambda* (x #:optional (m 'e) (esew '(eval)))
- (letrec* ((unstrip
- (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)))))))
+ (expand-top-sequence (list x) null-env top-wrap #f m esew (cons
'hygiene (module-name (current-module))))))
(set! identifier? (lambda (x) (nonsymbol-id? x)))
(set! datum->syntax
(lambda* (id datum #:key (source #f #:source))
@@ -2482,7 +2453,7 @@
(if id (syntax-wrap id) empty-wrap)
(and id (syntax-module id))
(cond
- ((not source) (props->sourcev (source-properties datum)))
+ ((not source) #f)
((and (list? source) (and-map pair? source)) (props->sourcev
source))
((and (vector? source) (= 3 (vector-length source))) source)
(else (syntax-sourcev source)))))))
@@ -2822,9 +2793,9 @@
#f
k
'()
- (map (lambda (tmp-680b775fb37a463-145d
tmp-680b775fb37a463-145c tmp-680b775fb37a463-145b)
- (list (cons tmp-680b775fb37a463-145b
tmp-680b775fb37a463-145c)
- tmp-680b775fb37a463-145d))
+ (map (lambda (tmp-680b775fb37a463-143f
tmp-680b775fb37a463-143e tmp-680b775fb37a463-143d)
+ (list (cons tmp-680b775fb37a463-143d
tmp-680b775fb37a463-143e)
+ tmp-680b775fb37a463-143f))
template
pattern
keyword)))
@@ -2852,11 +2823,9 @@
dots
k
'()
- (map (lambda (tmp-680b775fb37a463-148f
- tmp-680b775fb37a463-148e
- tmp-680b775fb37a463-148d)
- (list (cons
tmp-680b775fb37a463-148d tmp-680b775fb37a463-148e)
- tmp-680b775fb37a463-148f))
+ (map (lambda (tmp-680b775fb37a463-1
tmp-680b775fb37a463 tmp-680b775fb37a463-146f)
+ (list (cons
tmp-680b775fb37a463-146f tmp-680b775fb37a463)
+ tmp-680b775fb37a463-1))
template
pattern
keyword)))
@@ -2872,11 +2841,11 @@
dots
k
(list docstring)
- (map (lambda
(tmp-680b775fb37a463-14ae
-
tmp-680b775fb37a463-14ad
-
tmp-680b775fb37a463-14ac)
- (list (cons
tmp-680b775fb37a463-14ac tmp-680b775fb37a463-14ad)
-
tmp-680b775fb37a463-14ae))
+ (map (lambda (tmp-680b775fb37a463
+
tmp-680b775fb37a463-148f
+
tmp-680b775fb37a463-148e)
+ (list (cons
tmp-680b775fb37a463-148e tmp-680b775fb37a463-148f)
+ tmp-680b775fb37a463))
template
pattern
keyword)))
@@ -3004,9 +2973,9 @@
(apply (lambda (p)
(if (=
lev 0)
(quasilist*
-
(map (lambda (tmp-680b775fb37a463-155b)
+
(map (lambda (tmp-680b775fb37a463-153d)
(list "value"
-
tmp-680b775fb37a463-155b))
+
tmp-680b775fb37a463-153d))
p)
(quasi q lev))
(quasicons
@@ -3091,8 +3060,8 @@
(apply (lambda (p)
(if (= lev 0)
(quasiappend
- (map (lambda
(tmp-680b775fb37a463-157b)
- (list
"value" tmp-680b775fb37a463-157b))
+ (map (lambda
(tmp-680b775fb37a463-155d)
+ (list
"value" tmp-680b775fb37a463-155d))
p)
(vquasi q lev))
(quasicons
@@ -3174,8 +3143,8 @@
(let ((tmp-1 ls))
(let ((tmp ($sc-dispatch tmp-1
'each-any)))
(if tmp
- (apply (lambda
(t-680b775fb37a463-15c4)
- (cons "vector"
t-680b775fb37a463-15c4))
+ (apply (lambda
(t-680b775fb37a463-15a6)
+ (cons "vector"
t-680b775fb37a463-15a6))
tmp)
(syntax-violation
#f
@@ -3185,8 +3154,8 @@
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote")
each-any))))
(if tmp-1
(apply (lambda (y)
- (k (map (lambda
(tmp-680b775fb37a463-15d0)
- (list "quote"
tmp-680b775fb37a463-15d0))
+ (k (map (lambda
(tmp-680b775fb37a463-15b2)
+ (list "quote"
tmp-680b775fb37a463-15b2))
y)))
tmp-1)
(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)
(let ((else tmp))
(let ((tmp x))
- (let
((t-680b775fb37a463-15df tmp))
- (list "list->vector"
t-680b775fb37a463-15df)))))))))))))))))
+ (let
((t-680b775fb37a463-15c1 tmp))
+ (list "list->vector"
t-680b775fb37a463-15c1)))))))))))))))))
(emit (lambda (x)
(let ((tmp x))
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote")
any))))
@@ -3210,9 +3179,9 @@
(let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1
'each-any)))
(if tmp
- (apply (lambda
(t-680b775fb37a463-15ee)
+ (apply (lambda
(t-680b775fb37a463-15d0)
(cons
(make-syntax 'list '((top)) '(hygiene guile))
-
t-680b775fb37a463-15ee))
+
t-680b775fb37a463-15d0))
tmp)
(syntax-violation
#f
@@ -3228,13 +3197,14 @@
(let ((tmp-1 (list
(emit (car x*)) (f (cdr x*)))))
(let ((tmp
($sc-dispatch tmp-1 '(any any))))
(if tmp
- (apply
(lambda (t-680b775fb37a463-1 t-680b775fb37a463)
+ (apply
(lambda (t-680b775fb37a463-15e4
+
t-680b775fb37a463-15e3)
(list (make-syntax
'cons
'((top))
'(hygiene guile))
-
t-680b775fb37a463-1
-
t-680b775fb37a463))
+
t-680b775fb37a463-15e4
+
t-680b775fb37a463-15e3))
tmp)
(syntax-violation
#f
@@ -3247,12 +3217,12 @@
(let ((tmp-1 (map
emit x)))
(let ((tmp
($sc-dispatch tmp-1 'each-any)))
(if tmp
- (apply
(lambda (t-680b775fb37a463-160e)
+ (apply
(lambda (t-680b775fb37a463-15f0)
(cons (make-syntax
'append
'((top))
'(hygiene guile))
-
t-680b775fb37a463-160e))
+
t-680b775fb37a463-15f0))
tmp)
(syntax-violation
#f
@@ -3265,12 +3235,12 @@
(let ((tmp-1
(map emit x)))
(let ((tmp
($sc-dispatch tmp-1 'each-any)))
(if tmp
- (apply
(lambda (t-680b775fb37a463-161a)
+ (apply
(lambda (t-680b775fb37a463-15fc)
(cons (make-syntax
'vector
'((top))
'(hygiene guile))
-
t-680b775fb37a463-161a))
+
t-680b775fb37a463-15fc))
tmp)
(syntax-violation
#f
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 84fcd7262..91c333e2f 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -1,6 +1,6 @@
;;;; -*-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.
;;;;
;;;; This library is free software: you can redistribute it and/or modify
@@ -303,17 +303,8 @@
(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)
- (if (syntax? x)
- (syntax-sourcev x)
- (datum-sourcev x)))
+ (and (syntax? x) (syntax-sourcev x)))
(define-syntax-rule (arg-check pred? e who)
(let ((x e))
@@ -1863,14 +1854,9 @@
;; strips syntax objects, recursively.
(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
((syntax? x)
- (annotate syntax-sourcev (strip (syntax-expression x))))
+ (strip (syntax-expression x)))
((pair? x)
(cons (strip (car x)) (strip (cdr x))))
((vector? x)
@@ -2592,21 +2578,7 @@
;; expanded, and the expanded definitions are also residualized into
;; the object file if we are compiling a file.
(define*/override (macroexpand x #:optional (m 'e) (esew '(eval)))
- (define (unstrip x)
- (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
+ (expand-top-sequence (list x) null-env top-wrap #f m esew
(cons 'hygiene (module-name (current-module)))))
(define/override (identifier? x)
@@ -2626,8 +2598,7 @@
(syntax-module id)
#f)
(cond
- ((not source)
- (props->sourcev (source-properties datum)))
+ ((not source) #f)
((and (list? source) (and-map pair? source))
(props->sourcev source))
((and (vector? source) (= 3 (vector-length source)))
diff --git a/test-suite/tests/compiler.test b/test-suite/tests/compiler.test
index 0b47d0e32..788433b99 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
@@ -76,13 +76,10 @@
(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>
(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/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/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 <wi...@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
