[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 04/04: Avoid source properties in psyntax
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 04/04: Avoid source properties in psyntax |
|
Date: |
Tue, 1 Feb 2022 12:27:17 -0500 (EST) |
wingo pushed a commit to branch main
in repository guile.
commit 54bbe0b2846c5b1aa366c91d679ba724869c8cda
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Tue Feb 1 16:25:03 2022 +0100
Avoid source properties in psyntax
* module/ice-9/psyntax.scm (source-annotation): Only return source
properties from syntax objects.
(source-wrap): Don't look for source properties.
(expand-macro): Rebuild source properties on macro output via
source-wrap, not source properties. Only annotate head of a chain of
pairs.
(strip): Here's the only use of set-source-properties!: when stripping
a syntax object to a datum.
(macroexpand): If the input expression is not a syntax object, eagerly
extract its source properties.
(datum->syntax): Fix case in which source is given as an alist.
* module/ice-9/psyntax-pp.scm: Regenerate.
---
module/ice-9/psyntax-pp.scm | 225 ++++++++++++++++++++++++--------------------
module/ice-9/psyntax.scm | 81 +++++++++-------
2 files changed, 170 insertions(+), 136 deletions(-)
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index 12967d031..80be7249a 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -140,11 +140,6 @@
(sourcev-filename sourcev)
(list (cons 'line (sourcev-line sourcev))
(cons 'column (sourcev-column sourcev))))))))
- (decorate-source
- (lambda (e s)
- (if (and s (supports-source-properties? e))
- (set-source-properties! e (sourcev->alist s)))
- e))
(maybe-name-value!
(lambda (name val)
(if (lambda? val)
@@ -282,16 +277,7 @@
vars
val-exps
body-exp)))))
- (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))))
(extend-env
(lambda (labels bindings r)
(if (null? labels)
@@ -589,7 +575,7 @@
(cond ((and (null? (car w)) (null? (cdr w)) (not defmod) (not s)) x)
((syntax? x) (wrap-syntax x (join-wraps w (syntax-wrap x))
defmod))
((null? x) x)
- (else (make-syntax x w defmod (or s (datum-sourcev x)))))))
+ (else (make-syntax x w defmod s)))))
(expand-sequence
(lambda (body r w s mod)
(build-sequence
@@ -837,10 +823,12 @@
'define-form
(wrap name w mod)
(wrap e w mod)
- (decorate-source
+ (source-wrap
(cons (make-syntax 'lambda
'((top)) '(hygiene guile))
(wrap (cons args
(cons e1 e2)) w mod))
- s)
+ '(())
+ s
+ #f)
'(())
s
mod))
@@ -1009,13 +997,15 @@
(expand-macro
(lambda (p e r w s rib mod)
(letrec*
- ((rebuild-macro-output
+ ((decorate-source (lambda (x) (source-wrap x '(()) s #f)))
+ (map* (lambda (f x)
+ (cond ((null? x) x)
+ ((pair? x) (cons (f (car x)) (map* f (cdr x))))
+ (else (f x)))))
+ (rebuild-macro-output
(lambda (x m)
(cond ((pair? x)
- (decorate-source
- (cons (rebuild-macro-output (car x) m)
- (rebuild-macro-output (cdr x) m))
- s))
+ (decorate-source (map* (lambda (x)
(rebuild-macro-output x m)) x)))
((syntax? x)
(let ((w (syntax-wrap x)))
(let ((ms (car w)) (ss (cdr w)))
@@ -1030,25 +1020,26 @@
(if rib (cons rib (cons 'shift ss)) (cons
'shift ss)))
mod)))))
((vector? x)
- (let* ((n (vector-length x)) (v (decorate-source
(make-vector n) s)))
+ (let* ((n (vector-length x)) (v (make-vector n)))
(let loop ((i 0))
(if (= i n)
(begin (if #f #f) v)
(begin
(vector-set! v i (rebuild-macro-output
(vector-ref x i) m))
- (loop (+ i 1)))))))
+ (loop (+ i 1)))))
+ (decorate-source v)))
((symbol? x)
(syntax-violation
#f
"encountered raw symbol in macro output"
(source-wrap e w (cdr w) mod)
x))
- (else (decorate-source x s))))))
- (let* ((t-680b775fb37a463-ddd transformer-environment)
- (t-680b775fb37a463-dde (lambda (k) (k e r w s rib mod))))
+ (else (decorate-source x))))))
+ (let* ((t-680b775fb37a463-de2 transformer-environment)
+ (t-680b775fb37a463-de3 (lambda (k) (k e r w s rib mod))))
(with-fluid*
- t-680b775fb37a463-ddd
- t-680b775fb37a463-dde
+ t-680b775fb37a463-de2
+ t-680b775fb37a463-de3
(lambda ()
(rebuild-macro-output
(p (source-wrap e (anti-mark w) s mod))
@@ -1617,9 +1608,11 @@
s
mod
get-formals
- (map (lambda (tmp-680b775fb37a463-2
tmp-680b775fb37a463-1 tmp-680b775fb37a463)
- (cons tmp-680b775fb37a463
- (cons
tmp-680b775fb37a463-1 tmp-680b775fb37a463-2)))
+ (map (lambda (tmp-680b775fb37a463-1
+ tmp-680b775fb37a463
+
tmp-680b775fb37a463-105f)
+ (cons tmp-680b775fb37a463-105f
+ (cons
tmp-680b775fb37a463 tmp-680b775fb37a463-1)))
e2*
e1*
args*)))
@@ -1634,12 +1627,15 @@
tmp))))))))
(strip (lambda (x)
(letrec*
- ((annotate (lambda (proc datum) (decorate-source datum (proc
x)))))
+ ((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)
- (annotate datum-sourcev (cons (strip (car x)) (strip
(cdr x)))))
- ((vector? x)
- (annotate datum-sourcev (list->vector (strip
(vector->list x)))))
+ ((pair? x) (cons (strip (car x)) (strip (cdr x))))
+ ((vector? x) (list->vector (strip (vector->list x))))
(else x)))))
(gen-var
(lambda (id)
@@ -1925,11 +1921,11 @@
(apply (lambda (args e1 e2)
(build-it
'()
- (map (lambda (tmp-680b775fb37a463-6b2
- tmp-680b775fb37a463-6b1
- tmp-680b775fb37a463-6b0)
- (cons tmp-680b775fb37a463-6b0
- (cons tmp-680b775fb37a463-6b1
tmp-680b775fb37a463-6b2)))
+ (map (lambda (tmp-680b775fb37a463-6c1
+ tmp-680b775fb37a463-6c0
+ tmp-680b775fb37a463-6bf)
+ (cons tmp-680b775fb37a463-6bf
+ (cons tmp-680b775fb37a463-6c0
tmp-680b775fb37a463-6c1)))
e2
e1
args)))
@@ -1941,11 +1937,11 @@
(apply (lambda (docstring args e1 e2)
(build-it
(list (cons 'documentation (syntax->datum
docstring)))
- (map (lambda (tmp-680b775fb37a463-6c8
- tmp-680b775fb37a463-6c7
- tmp-680b775fb37a463-6c6)
- (cons tmp-680b775fb37a463-6c6
- (cons tmp-680b775fb37a463-6c7
tmp-680b775fb37a463-6c8)))
+ (map (lambda (tmp-680b775fb37a463-6d7
+ tmp-680b775fb37a463-6d6
+ tmp-680b775fb37a463-6d5)
+ (cons tmp-680b775fb37a463-6d5
+ (cons tmp-680b775fb37a463-6d6
tmp-680b775fb37a463-6d7)))
e2
e1
args)))
@@ -1968,11 +1964,9 @@
(apply (lambda (args e1 e2)
(build-it
'()
- (map (lambda (tmp-680b775fb37a463-67c
- tmp-680b775fb37a463-67b
- tmp-680b775fb37a463-67a)
- (cons tmp-680b775fb37a463-67a
- (cons tmp-680b775fb37a463-67b
tmp-680b775fb37a463-67c)))
+ (map (lambda (tmp-680b775fb37a463-68b
tmp-680b775fb37a463-68a tmp-680b775fb37a463)
+ (cons tmp-680b775fb37a463
+ (cons tmp-680b775fb37a463-68a
tmp-680b775fb37a463-68b)))
e2
e1
args)))
@@ -1984,9 +1978,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)
- (cons tmp-680b775fb37a463
- (cons tmp-680b775fb37a463-1
tmp-680b775fb37a463-2)))
+ (map (lambda (tmp-680b775fb37a463-6a1
+ tmp-680b775fb37a463-6a0
+ tmp-680b775fb37a463-69f)
+ (cons tmp-680b775fb37a463-69f
+ (cons tmp-680b775fb37a463-6a0
tmp-680b775fb37a463-6a1)))
e2
e1
args)))
@@ -2476,25 +2472,47 @@
tmp-1))))))
(set! macroexpand
(lambda* (x #:optional (m 'e) (esew '(eval)))
- (expand-top-sequence
- (list x)
- '()
- '((top))
- #f
- m
- esew
- (cons 'hygiene (module-name (current-module))))))
+ (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))
+ '()
+ '((top))
+ #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))
- (make-syntax
- datum
- (if id (syntax-wrap id) '(()))
- (and id (syntax-module id))
- (cond ((not source) (datum-sourcev datum))
- ((and (list? source) (and-map pair? source)) source)
- ((and (vector? source) (= 3 (vector-length source))) source)
- (else (syntax-sourcev source))))))
+ (letrec*
+ ((props->sourcev
+ (lambda (alist)
+ (and (pair? alist)
+ (vector
+ (assq-ref alist 'filename)
+ (assq-ref alist 'line)
+ (assq-ref alist 'column))))))
+ (make-syntax
+ datum
+ (if id (syntax-wrap id) '(()))
+ (and id (syntax-module id))
+ (cond ((not source) (props->sourcev (source-properties datum)))
+ ((and (list? source) (and-map pair? source)) (props->sourcev
source))
+ ((and (vector? source) (= 3 (vector-length source))) source)
+ (else (syntax-sourcev source)))))))
(set! syntax->datum (lambda (x) (strip x)))
(set! generate-temporaries
(lambda (ls)
@@ -2900,11 +2918,9 @@
#f
k
'()
- (map (lambda (tmp-680b775fb37a463-116d
- tmp-680b775fb37a463-116c
- tmp-680b775fb37a463-116b)
- (list (cons tmp-680b775fb37a463-116b
tmp-680b775fb37a463-116c)
- tmp-680b775fb37a463-116d))
+ (map (lambda (tmp-680b775fb37a463-1
tmp-680b775fb37a463 tmp-680b775fb37a463-117f)
+ (list (cons tmp-680b775fb37a463-117f
tmp-680b775fb37a463)
+ tmp-680b775fb37a463-1))
template
pattern
keyword)))
@@ -2920,9 +2936,9 @@
#f
k
(list docstring)
- (map (lambda (tmp-680b775fb37a463-2
tmp-680b775fb37a463-1 tmp-680b775fb37a463)
+ (map (lambda (tmp-680b775fb37a463-119a
tmp-680b775fb37a463-1 tmp-680b775fb37a463)
(list (cons tmp-680b775fb37a463
tmp-680b775fb37a463-1)
- tmp-680b775fb37a463-2))
+ tmp-680b775fb37a463-119a))
template
pattern
keyword)))
@@ -2937,11 +2953,11 @@
dots
k
'()
- (map (lambda (tmp-680b775fb37a463-119f
- tmp-680b775fb37a463-119e
- tmp-680b775fb37a463-119d)
- (list (cons tmp-680b775fb37a463-119d
tmp-680b775fb37a463-119e)
- tmp-680b775fb37a463-119f))
+ (map (lambda (tmp-680b775fb37a463-11b3
+ tmp-680b775fb37a463-11b2
+ tmp-680b775fb37a463-11b1)
+ (list (cons tmp-680b775fb37a463-11b1
tmp-680b775fb37a463-11b2)
+ tmp-680b775fb37a463-11b3))
template
pattern
keyword)))
@@ -2957,11 +2973,11 @@
dots
k
(list docstring)
- (map (lambda (tmp-680b775fb37a463-11be
- tmp-680b775fb37a463-11bd
- tmp-680b775fb37a463-11bc)
- (list (cons
tmp-680b775fb37a463-11bc tmp-680b775fb37a463-11bd)
- tmp-680b775fb37a463-11be))
+ (map (lambda (tmp-680b775fb37a463-11d2
+ tmp-680b775fb37a463-11d1
+ tmp-680b775fb37a463-11d0)
+ (list (cons
tmp-680b775fb37a463-11d0 tmp-680b775fb37a463-11d1)
+ tmp-680b775fb37a463-11d2))
template
pattern
keyword)))
@@ -3109,8 +3125,8 @@
(apply (lambda (p)
(if (= lev 0)
(quasilist*
- (map (lambda
(tmp-680b775fb37a463-126e)
- (list
"value" tmp-680b775fb37a463-126e))
+ (map (lambda
(tmp-680b775fb37a463)
+ (list
"value" tmp-680b775fb37a463))
p)
(quasi q lev))
(quasicons
@@ -3168,7 +3184,8 @@
(apply (lambda (p)
(if (= lev 0)
(quasilist*
- (map (lambda
(tmp-680b775fb37a463) (list "value" tmp-680b775fb37a463))
+ (map (lambda
(tmp-680b775fb37a463-129d)
+ (list "value"
tmp-680b775fb37a463-129d))
p)
(vquasi q lev))
(quasicons
@@ -3187,8 +3204,8 @@
(apply (lambda (p)
(if (= lev 0)
(quasiappend
- (map (lambda
(tmp-680b775fb37a463-128e)
- (list "value"
tmp-680b775fb37a463-128e))
+ (map (lambda
(tmp-680b775fb37a463-12a2)
+ (list "value"
tmp-680b775fb37a463-12a2))
p)
(vquasi q lev))
(quasicons
@@ -3278,8 +3295,8 @@
(let ((tmp-1 ls))
(let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp
- (apply (lambda (t-680b775fb37a463-12d7)
- (cons "vector"
t-680b775fb37a463-12d7))
+ (apply (lambda (t-680b775fb37a463-12eb)
+ (cons "vector"
t-680b775fb37a463-12eb))
tmp)
(syntax-violation
#f
@@ -3289,8 +3306,8 @@
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote")
each-any))))
(if tmp-1
(apply (lambda (y)
- (k (map (lambda (tmp-680b775fb37a463-12e3)
- (list "quote"
tmp-680b775fb37a463-12e3))
+ (k (map (lambda (tmp-680b775fb37a463-12f7)
+ (list "quote"
tmp-680b775fb37a463-12f7))
y)))
tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") .
each-any))))
@@ -3301,8 +3318,8 @@
(apply (lambda (y z) (f z (lambda (ls) (k
(append y ls))))) tmp-1)
(let ((else tmp))
(let ((tmp x))
- (let ((t-680b775fb37a463-12f2 tmp))
- (list "list->vector"
t-680b775fb37a463-12f2)))))))))))))))))
+ (let ((t-680b775fb37a463 tmp))
+ (list "list->vector"
t-680b775fb37a463)))))))))))))))))
(emit (lambda (x)
(let ((tmp x))
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any))))
@@ -3364,9 +3381,9 @@
(let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch
tmp-1 'each-any)))
(if tmp
- (apply (lambda
(t-680b775fb37a463-132d)
+ (apply (lambda
(t-680b775fb37a463)
(cons
(make-syntax 'vector '((top)) '(hygiene guile))
-
t-680b775fb37a463-132d))
+
t-680b775fb37a463))
tmp)
(syntax-violation
#f
@@ -3377,9 +3394,9 @@
(if tmp-1
(apply (lambda (x)
(let ((tmp (emit x)))
- (let ((t-680b775fb37a463
tmp))
+ (let
((t-680b775fb37a463-134d tmp))
(list (make-syntax
'list->vector '((top)) '(hygiene guile))
-
t-680b775fb37a463))))
+
t-680b775fb37a463-134d))))
tmp-1)
(let ((tmp-1 ($sc-dispatch tmp
'(#(atom "value") any))))
(if tmp-1
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index 054d21795..35758ab4c 100644
--- a/module/ice-9/psyntax.scm
+++ b/module/ice-9/psyntax.scm
@@ -1,6 +1,6 @@
;;;; -*-scheme-*-
;;;;
-;;;; Copyright (C) 2001, 2003, 2006, 2009, 2010-2021
+;;;; Copyright (C) 2001, 2003, 2006, 2009, 2010-2022
;;;; Free Software Foundation, Inc.
;;;;
;;;; This library is free software; you can redistribute it and/or
@@ -278,11 +278,6 @@
`((line . ,(sourcev-line sourcev))
(column . ,(sourcev-column sourcev))))))
- (define (decorate-source e s)
- (when (and s (supports-source-properties? e))
- (set-source-properties! e (sourcev->alist s)))
- e)
-
(define (maybe-name-value! name val)
(if (lambda? val)
(let ((meta (lambda-meta val)))
@@ -436,18 +431,10 @@
(define-syntax no-source (identifier-syntax #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
(lambda (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))
@@ -1044,7 +1031,7 @@
x)
((syntax? x) (wrap-syntax x (join-wraps w (syntax-wrap x)) defmod))
((null? x) x)
- (else (make-syntax x w defmod (or s (datum-sourcev x))))))
+ (else (make-syntax x w defmod s))))
;; expanding
@@ -1366,9 +1353,9 @@
;; need lambda here...
(values 'define-form (wrap #'name w mod)
(wrap e w mod)
- (decorate-source
+ (source-wrap
(cons #'lambda (wrap #'(args e1 e2 ...) w mod))
- s)
+ empty-wrap s #f)
empty-wrap s mod))
((_ name)
(id? #'name)
@@ -1514,13 +1501,18 @@
;; possible.
(define expand-macro
(lambda (p e r w s rib mod)
+ (define (decorate-source x)
+ (source-wrap x empty-wrap s #f))
+ (define (map* f x)
+ (cond
+ ((null? x) x)
+ ((pair? x) (cons (f (car x)) (map* f (cdr x))))
+ (else (f x))))
(define rebuild-macro-output
(lambda (x m)
(cond ((pair? x)
- (decorate-source
- (cons (rebuild-macro-output (car x) m)
- (rebuild-macro-output (cdr x) m))
- s))
+ (decorate-source
+ (map* (lambda (x) (rebuild-macro-output x m)) x)))
((syntax? x)
(let ((w (syntax-wrap x)))
(let ((ms (wrap-marks w)) (ss (wrap-subst w)))
@@ -1544,15 +1536,16 @@
((vector? x)
(let* ((n (vector-length x))
- (v (decorate-source (make-vector n) s)))
+ (v (make-vector n)))
(do ((i 0 (fx+ i 1)))
((fx= i n) v)
(vector-set! v i
- (rebuild-macro-output (vector-ref x i)
m)))))
+ (rebuild-macro-output (vector-ref x i) m)))
+ (decorate-source v)))
((symbol? x)
(syntax-violation #f "encountered raw symbol in macro
output"
(source-wrap e w (wrap-subst w) mod) x))
- (else (decorate-source x s)))))
+ (else (decorate-source x)))))
(with-fluids ((transformer-environment
(lambda (k) (k e r w s rib mod))))
(rebuild-macro-output (p (source-wrap e (anti-mark w) s mod))
@@ -1997,14 +1990,17 @@
(define (strip x)
(define (annotate proc datum)
- (decorate-source datum (proc x)))
+ (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))))
((pair? x)
- (annotate datum-sourcev (cons (strip (car x)) (strip (cdr x)))))
+ (cons (strip (car x)) (strip (cdr x))))
((vector? x)
- (annotate datum-sourcev (list->vector (strip (vector->list x)))))
+ (list->vector (strip (vector->list x))))
(else x)))
;; lexical variables
@@ -2739,7 +2735,21 @@
;; the object file if we are compiling a file.
(set! macroexpand
(lambda* (x #:optional (m 'e) (esew '(eval)))
- (expand-top-sequence (list x) null-env top-wrap #f m esew
+ (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
(cons 'hygiene (module-name
(current-module))))))
(set! identifier?
@@ -2748,6 +2758,11 @@
(set! datum->syntax
(lambda* (id datum #:key source)
+ (define (props->sourcev alist)
+ (and (pair? alist)
+ (vector (assq-ref alist 'filename)
+ (assq-ref alist 'line)
+ (assq-ref alist 'column))))
(make-syntax datum
(if id
(syntax-wrap id)
@@ -2756,8 +2771,10 @@
(syntax-module id)
#f)
(cond
- ((not source) (datum-sourcev datum))
- ((and (list? source) (and-map pair? source)) source)
+ ((not source)
+ (props->sourcev (source-properties datum)))
+ ((and (list? source) (and-map pair? source))
+ (props->sourcev source))
((and (vector? source) (= 3 (vector-length source)))
source)
(else (syntax-sourcev source))))))