mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-08 13:10:19 +02:00
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.
This commit is contained in:
Andy Wingo
parent
05dd829ad3
commit
f399f36d37
7 changed files with 127 additions and 182 deletions
|
|
@ -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
|
||||
|
|
|
|||
|
|
@ -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)))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue