mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-04 19:20:27 +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

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

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

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

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

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

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

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

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

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

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