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 (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 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) + (("#") + 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 --- 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