mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-12 14:50:19 +02:00
Code Activity

syntax-source returns a vector

Browse source 
* libguile/syntax.c (HAS_SOURCE_WORD_FLAG): Remove; all syntax objects
now have a source word.
(sourcev_to_props, props_to_sourcev): Remove.
(scm_make_syntax): Require source to be a vector or #f.
(scm_syntax_source): Just return source object.
(scm_syntax_sourcev): Remove.
* libguile/syntax.h: Remove scm_syntax_sourcev.
* module/srfi/srfi-64.scm (syntax->source-properties):
* module/system/base/types.scm (cell->object):
* module/ice-9/boot-9.scm (case, current-source-location, current-filename)
(define-module, load): Adapt for syntax-source returning a vector.
* module/ice-9/psyntax-pp.scm: Regen.
* module/ice-9/psyntax.scm: Rename uses of syntax-sourcev to
syntax-source.
* module/system/syntax.scm (syntax-sourcev): Add deprecated shim.
(print-syntax): Use sourcev.
* module/system/vm/assembler.scm (intern-constant):
(link-data): Always write source word.
* test-suite/tests/reader.test ("read-syntax"): Update expectation.
This commit is contained in:
Andy Wingo 2025-05-12 15:01:35 +02:00
parent 71d112cdde
commit b6b6f62548
10 changed files with 120 additions and 163 deletions
Download patch file Download diff file Expand all files Collapse all files

62
libguile/syntax.c
View file

@ -1,4 +1,4 @@
/* Copyright 2017-2018,2021 /* Copyright 2017-2018,2021,2025
Free Software Foundation, Inc. Free Software Foundation, Inc.
This file is part of Guile. This file is part of Guile.
@ -41,12 +41,6 @@
/* The source field was added to syntax objects in Guile 3.0.6. However
there can be older syntax objects present in compiled files that
don't have the source field. If a syntax object has a source field,
its tag will have HAS_SOURCE_WORD_FLAG set. */
#define HAS_SOURCE_WORD_FLAG 0x100
enum enum
{ {
TAG_WORD, TAG_WORD,
@ -76,40 +70,17 @@ SCM_DEFINE (scm_syntax_p, "syntax?", 1, 0, 0,
} }
#undef FUNC_NAME #undef FUNC_NAME
static SCM
sourcev_to_props (SCM v)
{
SCM props = scm_acons (scm_sym_line, scm_c_vector_ref (v, 1),
scm_acons (scm_sym_column, scm_c_vector_ref (v, 2),
SCM_EOL));
if (scm_is_true (scm_c_vector_ref (v, 0)))
props = scm_acons (scm_sym_filename, scm_c_vector_ref (v, 0), props);
return props;
}
static SCM
props_to_sourcev (SCM props)
{
SCM v = scm_c_make_vector (3, SCM_BOOL_F);
scm_c_vector_set_x (v, 0, scm_assq_ref (props, scm_sym_filename));
scm_c_vector_set_x (v, 1, scm_assq_ref (props, scm_sym_line));
scm_c_vector_set_x (v, 2, scm_assq_ref (props, scm_sym_column));
return v;
}
SCM_DEFINE (scm_make_syntax, "make-syntax", 3, 1, 0, SCM_DEFINE (scm_make_syntax, "make-syntax", 3, 1, 0,
(SCM exp, SCM wrap, SCM module, SCM source), (SCM exp, SCM wrap, SCM module, SCM source),
"Make a new syntax object.") "Make a new syntax object.")
#define FUNC_NAME s_scm_make_syntax #define FUNC_NAME s_scm_make_syntax
{ {
if (SCM_UNBNDP (source)) if (SCM_UNBNDP (source))
source = scm_source_properties (exp);
if (scm_is_pair (source))
source = props_to_sourcev (source);
if (!scm_is_vector (source))
source = SCM_BOOL_F; source = SCM_BOOL_F;
else if (!scm_is_eq (source, SCM_BOOL_F))
SCM_VALIDATE_VECTOR (1, source);
SCM ret = scm_words (scm_tc7_syntax | HAS_SOURCE_WORD_FLAG, WORD_COUNT); SCM ret = scm_words (scm_tc7_syntax, WORD_COUNT);
SCM_SET_CELL_OBJECT (ret, EXPR_WORD, exp); SCM_SET_CELL_OBJECT (ret, EXPR_WORD, exp);
SCM_SET_CELL_OBJECT (ret, WRAP_WORD, wrap); SCM_SET_CELL_OBJECT (ret, WRAP_WORD, wrap);
SCM_SET_CELL_OBJECT (ret, MODULE_WORD, module); SCM_SET_CELL_OBJECT (ret, MODULE_WORD, module);
@ -158,30 +129,7 @@ SCM_DEFINE (scm_syntax_source, "syntax-source", 1, 0, 0,
#define FUNC_NAME s_scm_syntax_source #define FUNC_NAME s_scm_syntax_source
{ {
SCM_VALIDATE_SYNTAX (1, obj); SCM_VALIDATE_SYNTAX (1, obj);
if (!(SCM_CELL_WORD (obj, TAG_WORD) & HAS_SOURCE_WORD_FLAG)) return SCM_CELL_OBJECT (obj, SOURCE_WORD);
return SCM_BOOL_F;
SCM src = SCM_CELL_OBJECT (obj, SOURCE_WORD);
if (scm_is_vector (src))
src = sourcev_to_props (src);
return src;
}
#undef FUNC_NAME
SCM_DEFINE (scm_syntax_sourcev, "syntax-sourcev", 1, 0, 0,
(SCM obj),
"Return the source location information for syntax object\n"
"@var{obj}, as a vector of @code{#(@var{filename} @var{line}\n"
"@var{column})}, or @code{#f} if no source properties are\n"
"available.")
#define FUNC_NAME s_scm_syntax_sourcev
{
SCM_VALIDATE_SYNTAX (1, obj);
if (!(SCM_CELL_WORD (obj, TAG_WORD) & HAS_SOURCE_WORD_FLAG))
return SCM_BOOL_F;
SCM src = SCM_CELL_OBJECT (obj, SOURCE_WORD);
if (scm_is_null (src) || scm_is_pair (src))
src = props_to_sourcev (src);
return src;
} }
#undef FUNC_NAME #undef FUNC_NAME

3
libguile/syntax.h
View file

@ -1,7 +1,7 @@
#ifndef SCM_SYNTAX_H #ifndef SCM_SYNTAX_H
#define SCM_SYNTAX_H #define SCM_SYNTAX_H
/* Copyright 2017-2018,2021 /* Copyright 2017-2018,2021,2025
Free Software Foundation, Inc. Free Software Foundation, Inc.
This file is part of Guile. This file is part of Guile.
@ -28,7 +28,6 @@ SCM_INTERNAL SCM scm_syntax_expression (SCM obj);
SCM_INTERNAL SCM scm_syntax_wrap (SCM obj); SCM_INTERNAL SCM scm_syntax_wrap (SCM obj);
SCM_INTERNAL SCM scm_syntax_module (SCM obj); SCM_INTERNAL SCM scm_syntax_module (SCM obj);
SCM_INTERNAL SCM scm_syntax_source (SCM obj); SCM_INTERNAL SCM scm_syntax_source (SCM obj);
SCM_INTERNAL SCM scm_syntax_sourcev (SCM obj);
SCM_INTERNAL void scm_i_syntax_print (SCM obj, SCM port, SCM_INTERNAL void scm_i_syntax_print (SCM obj, SCM port,
scm_print_state *pstate); scm_print_state *pstate);

36
module/ice-9/boot-9.scm
View file

@ -554,8 +554,7 @@ If returning early, return the return value of F."
warning) warning)
type type
(or (syntax-source datum) (or (syntax-source datum)
(syntax-source #'test) (syntax-source #'test))
'())
raw raw
(syntax->datum clause) (syntax->datum clause)
(syntax->datum whole-expr))) (syntax->datum whole-expr)))
@ -688,8 +687,17 @@ If returning early, return the return value of F."
(lambda (x) (lambda (x)
(syntax-case x () (syntax-case x ()
((_) ((_)
(with-syntax ((s (datum->syntax x (syntax-source x)))) (cond
#''s))))) ((syntax-source x)
=> (lambda (v)
(with-syntax ((f (vector-ref v 0))
(l (vector-ref v 1))
(c (vector-ref v 2)))
#''((filename . f)
(line . l)
(column . c)))))
(else
#'#f))))))
;; We provide this accessor out of convenience. current-line and ;; We provide this accessor out of convenience. current-line and
;; current-column aren't so interesting, because they distort what they ;; current-column aren't so interesting, because they distort what they
@ -700,8 +708,11 @@ If returning early, return the return value of F."
"A macro that expands to the current filename: the filename that "A macro that expands to the current filename: the filename that
the (current-filename) form appears in. Expands to #f if this the (current-filename) form appears in. Expands to #f if this
information is unavailable." information is unavailable."
(false-if-exception (and=> (syntax-source x)
(canonicalize-path (assq-ref (syntax-source x) 'filename))))) (lambda (v)
(and=> (vector-ref v 0)
(lambda (filename)
(false-if-exception (canonicalize-path filename))))))))
(define-syntax-rule (define-once sym val) (define-syntax-rule (define-once sym val)
(define sym (define sym
@ -3838,9 +3849,11 @@ but it fails to load."
;; this hack is to work around a case in which ;; this hack is to work around a case in which
;; port-filename returns a symbol (`socket') for ;; port-filename returns a symbol (`socket') for
;; sockets. ;; sockets.
(filename (let ((f (assq-ref (or (syntax-source x) '()) (filename (and=> (syntax-source x)
'filename))) (lambda (v)
(and (string? f) f)))) (and=> (vector-ref v 0)
(lambda (f)
(and (string? f) f)))))))
#'(eval-when (expand load eval) #'(eval-when (expand load eval)
(let ((m (define-module* '(name name* ...) (let ((m (define-module* '(name name* ...)
#:filename filename quoted-arg ...))) #:filename filename quoted-arg ...)))
@ -4327,7 +4340,7 @@ when none is available, reading FILE-NAME with READER."
(make-variable-transformer (make-variable-transformer
(lambda (x) (lambda (x)
(let* ((src (syntax-source x)) (let* ((src (syntax-source x))
(file (and src (assq-ref src 'filename))) (file (and src (vector-ref src 0)))
(dir (and (string? file) (dirname file)))) (dir (and (string? file) (dirname file))))
;; A module that uses `load' is not declarative. ;; A module that uses `load' is not declarative.
(when (module-declarative? (current-module)) (when (module-declarative? (current-module))
@ -4665,8 +4678,7 @@ R7RS."
make-syntax make-syntax
syntax-expression syntax-expression
syntax-wrap syntax-wrap
syntax-module syntax-module)))
syntax-sourcev)))

117
module/ice-9/psyntax-pp.scm
View file

@ -5,8 +5,7 @@
(make-syntax (module-ref (current-module) 'make-syntax)) (make-syntax (module-ref (current-module) 'make-syntax))
(syntax-expression (module-ref (current-module) 'syntax-expression)) (syntax-expression (module-ref (current-module) 'syntax-expression))
(syntax-wrap (module-ref (current-module) 'syntax-wrap)) (syntax-wrap (module-ref (current-module) 'syntax-wrap))
(syntax-module (module-ref (current-module) 'syntax-module)) (syntax-module (module-ref (current-module) 'syntax-module)))
(syntax-sourcev (module-ref (current-module) 'syntax-sourcev)))
(letrec* ((make-void (lambda (src) (make-struct/simple (vector-ref %expanded-vtables 0) src))) (letrec* ((make-void (lambda (src) (make-struct/simple (vector-ref %expanded-vtables 0) src)))
(make-const (lambda (src exp) (make-struct/simple (vector-ref %expanded-vtables 1) src exp))) (make-const (lambda (src exp) (make-struct/simple (vector-ref %expanded-vtables 1) src exp)))
(make-primitive-ref (lambda (src name) (make-struct/simple (vector-ref %expanded-vtables 2) src name))) (make-primitive-ref (lambda (src name) (make-struct/simple (vector-ref %expanded-vtables 2) src name)))
@ -177,7 +176,7 @@
(if (null? v) body-exp (fk))))) (if (null? v) body-exp (fk)))))
(gen-lexical (lambda (id) (module-gensym (symbol->string id)))) (gen-lexical (lambda (id) (module-gensym (symbol->string id))))
(no-source #f) (no-source #f)
(source-annotation (lambda (x) (and (syntax? x) (syntax-sourcev x)))) (source-annotation (lambda (x) (and (syntax? x) (syntax-source x))))
(binding-type (lambda (x) (car x))) (binding-type (lambda (x) (car x)))
(binding-value (lambda (x) (cdr x))) (binding-value (lambda (x) (cdr x)))
(null-env '()) (null-env '())
@ -663,8 +662,7 @@
(if (null? v) #f (fk))))) (if (null? v) #f (fk)))))
(wrap (lambda (x w defmod) (source-wrap x w #f defmod))) (wrap (lambda (x w defmod) (source-wrap x w #f defmod)))
(wrap-syntax (wrap-syntax
(lambda (x w defmod) (lambda (x w defmod) (make-syntax (syntax-expression x) w (or (syntax-module x) defmod) (syntax-source x))))
(make-syntax (syntax-expression x) w (or (syntax-module x) defmod) (syntax-sourcev x))))
(source-wrap (source-wrap
(lambda (x w s defmod) (lambda (x w s defmod)
(cond (cond
@ -1137,11 +1135,11 @@
(source-wrap e w (wrap-subst w) mod) (source-wrap e w (wrap-subst w) mod)
x)) x))
(else (decorate-source x)))))) (else (decorate-source x))))))
(let* ((t-680b775fb37a463-c32 transformer-environment) (let* ((t-680b775fb37a463-c30 transformer-environment)
(t-680b775fb37a463-c33 (lambda (k) (k e r w s rib mod)))) (t-680b775fb37a463-c31 (lambda (k) (k e r w s rib mod))))
(with-fluid* (with-fluid*
t-680b775fb37a463-c32 t-680b775fb37a463-c30
t-680b775fb37a463-c33 t-680b775fb37a463-c31
(lambda () (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod)) (new-mark)))))))) (lambda () (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod)) (new-mark))))))))
(expand-body (expand-body
(lambda (body outer-form r w mod) (lambda (body outer-form r w mod)
@ -1672,11 +1670,11 @@
s s
mod mod
get-formals get-formals
(map (lambda (tmp-680b775fb37a463-ebb (map (lambda (tmp-680b775fb37a463-eb9
tmp-680b775fb37a463-eba tmp-680b775fb37a463-eb8
tmp-680b775fb37a463-eb9) tmp-680b775fb37a463-eb7)
(cons tmp-680b775fb37a463-eb9 (cons tmp-680b775fb37a463-eb7
(cons tmp-680b775fb37a463-eba tmp-680b775fb37a463-ebb))) (cons tmp-680b775fb37a463-eb8 tmp-680b775fb37a463-eb9)))
e2* e2*
e1* e1*
args*))) args*)))
@ -1954,11 +1952,9 @@
(apply (lambda (docstring args e1 e2) (apply (lambda (docstring args e1 e2)
(build-it (build-it
(list (cons 'documentation (syntax->datum docstring))) (list (cons 'documentation (syntax->datum docstring)))
(map (lambda (tmp-680b775fb37a463-112b (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
tmp-680b775fb37a463-112a
tmp-680b775fb37a463)
(cons tmp-680b775fb37a463 (cons tmp-680b775fb37a463
(cons tmp-680b775fb37a463-112a tmp-680b775fb37a463-112b))) (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2)))
e2 e2
e1 e1
args))) args)))
@ -1976,9 +1972,8 @@
(apply (lambda (args e1 e2) (apply (lambda (args e1 e2)
(build-it (build-it
'() '()
(map (lambda (tmp-680b775fb37a463-114b tmp-680b775fb37a463-114a tmp-680b775fb37a463) (map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
(cons tmp-680b775fb37a463 (cons tmp-680b775fb37a463 (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2)))
(cons tmp-680b775fb37a463-114a tmp-680b775fb37a463-114b)))
e2 e2
e1 e1
args))) args)))
@ -1988,9 +1983,11 @@
(apply (lambda (docstring args e1 e2) (apply (lambda (docstring args e1 e2)
(build-it (build-it
(list (cons 'documentation (syntax->datum docstring))) (list (cons 'documentation (syntax->datum docstring)))
(map (lambda (tmp-680b775fb37a463-1 tmp-680b775fb37a463 tmp-680b775fb37a463-115f) (map (lambda (tmp-680b775fb37a463-115f
(cons tmp-680b775fb37a463-115f tmp-680b775fb37a463-115e
(cons tmp-680b775fb37a463 tmp-680b775fb37a463-1))) tmp-680b775fb37a463-115d)
(cons tmp-680b775fb37a463-115d
(cons tmp-680b775fb37a463-115e tmp-680b775fb37a463-115f)))
e2 e2
e1 e1
args))) args)))
@ -2007,7 +2004,7 @@
'#{ $sc-ellipsis }# '#{ $sc-ellipsis }#
(syntax-wrap dots) (syntax-wrap dots)
(syntax-module dots) (syntax-module dots)
(syntax-sourcev dots))))) (syntax-source dots)))))
(let ((ids (list id)) (let ((ids (list id))
(labels (list (gen-label))) (labels (list (gen-label)))
(bindings (list (cons 'ellipsis (source-wrap dots w s mod))))) (bindings (list (cons 'ellipsis (source-wrap dots w s mod)))))
@ -2157,7 +2154,7 @@
(remodulate (syntax-expression x) mod) (remodulate (syntax-expression x) mod)
(syntax-wrap x) (syntax-wrap x)
mod mod
(syntax-sourcev x))) (syntax-source x)))
((vector? x) ((vector? x)
(let* ((n (vector-length x)) (v (make-vector n))) (let* ((n (vector-length x)) (v (make-vector n)))
(let loop ((i 0)) (let loop ((i 0))
@ -2456,7 +2453,7 @@
((not source) #f) ((not source) #f)
((and (list? source) (and-map pair? source)) (props->sourcev source)) ((and (list? source) (and-map pair? source)) (props->sourcev source))
((and (vector? source) (= 3 (vector-length source))) source) ((and (vector? source) (= 3 (vector-length source))) source)
(else (syntax-sourcev source))))))) (else (syntax-source source)))))))
(set! syntax->datum (lambda (x) (strip x))) (set! syntax->datum (lambda (x) (strip x)))
(set! generate-temporaries (set! generate-temporaries
(lambda (ls) (lambda (ls)
@ -2793,9 +2790,9 @@
#f #f
k k
'() '()
(map (lambda (tmp-680b775fb37a463-143f tmp-680b775fb37a463-143e tmp-680b775fb37a463-143d) (map (lambda (tmp-680b775fb37a463-143d tmp-680b775fb37a463-143c tmp-680b775fb37a463-143b)
(list (cons tmp-680b775fb37a463-143d tmp-680b775fb37a463-143e) (list (cons tmp-680b775fb37a463-143b tmp-680b775fb37a463-143c)
tmp-680b775fb37a463-143f)) tmp-680b775fb37a463-143d))
template template
pattern pattern
keyword))) keyword)))
@ -2823,9 +2820,11 @@
dots dots
k k
'() '()
(map (lambda (tmp-680b775fb37a463-1 tmp-680b775fb37a463 tmp-680b775fb37a463-146f) (map (lambda (tmp-680b775fb37a463-146f
(list (cons tmp-680b775fb37a463-146f tmp-680b775fb37a463) tmp-680b775fb37a463-146e
tmp-680b775fb37a463-1)) tmp-680b775fb37a463-146d)
(list (cons tmp-680b775fb37a463-146d tmp-680b775fb37a463-146e)
tmp-680b775fb37a463-146f))
template template
pattern pattern
keyword))) keyword)))
@ -2841,11 +2840,11 @@
dots dots
k k
(list docstring) (list docstring)
(map (lambda (tmp-680b775fb37a463 (map (lambda (tmp-680b775fb37a463-148e
tmp-680b775fb37a463-148f tmp-680b775fb37a463-148d
tmp-680b775fb37a463-148e) tmp-680b775fb37a463-148c)
(list (cons tmp-680b775fb37a463-148e tmp-680b775fb37a463-148f) (list (cons tmp-680b775fb37a463-148c tmp-680b775fb37a463-148d)
tmp-680b775fb37a463)) tmp-680b775fb37a463-148e))
template template
pattern pattern
keyword))) keyword)))
@ -2973,9 +2972,9 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasilist* (quasilist*
(map (lambda (tmp-680b775fb37a463-153d) (map (lambda (tmp-680b775fb37a463-153b)
(list "value" (list "value"
tmp-680b775fb37a463-153d)) tmp-680b775fb37a463-153b))
p) p)
(quasi q lev)) (quasi q lev))
(quasicons (quasicons
@ -3060,8 +3059,8 @@
(apply (lambda (p) (apply (lambda (p)
(if (= lev 0) (if (= lev 0)
(quasiappend (quasiappend
(map (lambda (tmp-680b775fb37a463-155d) (map (lambda (tmp-680b775fb37a463-155b)
(list "value" tmp-680b775fb37a463-155d)) (list "value" tmp-680b775fb37a463-155b))
p) p)
(vquasi q lev)) (vquasi q lev))
(quasicons (quasicons
@ -3143,8 +3142,8 @@
(let ((tmp-1 ls)) (let ((tmp-1 ls))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-15a6) (apply (lambda (t-680b775fb37a463-15a4)
(cons "vector" t-680b775fb37a463-15a6)) (cons "vector" t-680b775fb37a463-15a4))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3154,8 +3153,8 @@
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any))))
(if tmp-1 (if tmp-1
(apply (lambda (y) (apply (lambda (y)
(k (map (lambda (tmp-680b775fb37a463-15b2) (k (map (lambda (tmp-680b775fb37a463-15b0)
(list "quote" tmp-680b775fb37a463-15b2)) (list "quote" tmp-680b775fb37a463-15b0))
y))) y)))
tmp-1) tmp-1)
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "list") . each-any))))
@ -3166,8 +3165,8 @@
(apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1) (apply (lambda (y z) (f z (lambda (ls) (k (append y ls))))) tmp-1)
(let ((else tmp)) (let ((else tmp))
(let ((tmp x)) (let ((tmp x))
(let ((t-680b775fb37a463-15c1 tmp)) (let ((t-680b775fb37a463-15bf tmp))
(list "list->vector" t-680b775fb37a463-15c1))))))))))))))))) (list "list->vector" t-680b775fb37a463-15bf)))))))))))))))))
(emit (lambda (x) (emit (lambda (x)
(let ((tmp x)) (let ((tmp x))
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any)))) (let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any))))
@ -3179,9 +3178,9 @@
(let ((tmp-1 (map emit x))) (let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-15d0) (apply (lambda (t-680b775fb37a463-15ce)
(cons (make-syntax 'list '((top)) '(hygiene guile)) (cons (make-syntax 'list '((top)) '(hygiene guile))
t-680b775fb37a463-15d0)) t-680b775fb37a463-15ce))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3197,14 +3196,14 @@
(let ((tmp-1 (list (emit (car x*)) (f (cdr x*))))) (let ((tmp-1 (list (emit (car x*)) (f (cdr x*)))))
(let ((tmp ($sc-dispatch tmp-1 '(any any)))) (let ((tmp ($sc-dispatch tmp-1 '(any any))))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-15e4 (apply (lambda (t-680b775fb37a463-15e2
t-680b775fb37a463-15e3) t-680b775fb37a463-15e1)
(list (make-syntax (list (make-syntax
'cons 'cons
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463-15e4 t-680b775fb37a463-15e2
t-680b775fb37a463-15e3)) t-680b775fb37a463-15e1))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3217,12 +3216,12 @@
(let ((tmp-1 (map emit x))) (let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-15f0) (apply (lambda (t-680b775fb37a463-15ee)
(cons (make-syntax (cons (make-syntax
'append 'append
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463-15f0)) t-680b775fb37a463-15ee))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3235,12 +3234,12 @@
(let ((tmp-1 (map emit x))) (let ((tmp-1 (map emit x)))
(let ((tmp ($sc-dispatch tmp-1 'each-any))) (let ((tmp ($sc-dispatch tmp-1 'each-any)))
(if tmp (if tmp
(apply (lambda (t-680b775fb37a463-15fc) (apply (lambda (t-680b775fb37a463-15fa)
(cons (make-syntax (cons (make-syntax
'vector 'vector
'((top)) '((top))
'(hygiene guile)) '(hygiene guile))
t-680b775fb37a463-15fc)) t-680b775fb37a463-15fa))
tmp) tmp)
(syntax-violation (syntax-violation
#f #f
@ -3275,7 +3274,7 @@
(define call-with-include-port (define call-with-include-port
(let ((syntax-dirname (let ((syntax-dirname
(lambda (stx) (lambda (stx)
(letrec* ((src (syntax-source stx)) (filename (if src (assq-ref src 'filename) #f))) (letrec* ((src (syntax-source stx)) (filename (if src (vector-ref src 0) #f)))
(if (string? filename) (dirname filename) #f))))) (if (string? filename) (dirname filename) #f)))))
(lambda* (filename proc #:key (dirname (syntax-dirname filename) #:dirname)) (lambda* (filename proc #:key (dirname (syntax-dirname filename) #:dirname))
"Like @code{call-with-input-file}, except relative paths are\nsearched relative to the @var{dirname} instead of the current working\ndirectory. Also, @var{filename} can be a syntax object; in that case,\nand if @var{dirname} is not specified, the @code{syntax-source} of\n@var{filename} is used to obtain a base directory for relative file\nnames." "Like @code{call-with-input-file}, except relative paths are\nsearched relative to the @var{dirname} instead of the current working\ndirectory. Also, @var{filename} can be a syntax object; in that case,\nand if @var{dirname} is not specified, the @code{syntax-source} of\n@var{filename} is used to obtain a base directory for relative file\nnames."

15
module/ice-9/psyntax.scm
View file

@ -74,8 +74,7 @@
(make-syntax (module-ref (current-module) 'make-syntax)) (make-syntax (module-ref (current-module) 'make-syntax))
(syntax-expression (module-ref (current-module) 'syntax-expression)) (syntax-expression (module-ref (current-module) 'syntax-expression))
(syntax-wrap (module-ref (current-module) 'syntax-wrap)) (syntax-wrap (module-ref (current-module) 'syntax-wrap))
(syntax-module (module-ref (current-module) 'syntax-module)) (syntax-module (module-ref (current-module) 'syntax-module)))
(syntax-sourcev (module-ref (current-module) 'syntax-sourcev)))
(define-syntax define-expansion-constructors (define-syntax define-expansion-constructors
(lambda (x) (lambda (x)
@ -304,7 +303,7 @@
(define no-source #f) (define no-source #f)
(define (source-annotation x) (define (source-annotation x)
(and (syntax? x) (syntax-sourcev x))) (and (syntax? x) (syntax-source x)))
(define-syntax-rule (arg-check pred? e who) (define-syntax-rule (arg-check pred? e who)
(let ((x e)) (let ((x e))
@ -889,7 +888,7 @@
(make-syntax (syntax-expression x) (make-syntax (syntax-expression x)
w w
(or (syntax-module x) defmod) (or (syntax-module x) defmod)
(syntax-sourcev x))) (syntax-source x)))
(define (source-wrap x w s defmod) (define (source-wrap x w s defmod)
(cond (cond
((and (null? (wrap-marks w)) ((and (null? (wrap-marks w))
@ -2165,7 +2164,7 @@
(make-syntax '#{ $sc-ellipsis }# (make-syntax '#{ $sc-ellipsis }#
(syntax-wrap #'dots) (syntax-wrap #'dots)
(syntax-module #'dots) (syntax-module #'dots)
(syntax-sourcev #'dots))))) (syntax-source #'dots)))))
(let ((ids (list id)) (let ((ids (list id))
(labels (list (gen-label))) (labels (list (gen-label)))
(bindings (list (make-binding 'ellipsis (source-wrap #'dots w s mod))))) (bindings (list (make-binding 'ellipsis (source-wrap #'dots w s mod)))))
@ -2313,7 +2312,7 @@
(syntax-wrap x) (syntax-wrap x)
;; hither the remodulation ;; hither the remodulation
mod mod
(syntax-sourcev x))) (syntax-source x)))
((vector? x) ((vector? x)
(let* ((n (vector-length x)) (v (make-vector n))) (let* ((n (vector-length x)) (v (make-vector n)))
(do ((i 0 (1+ i))) (do ((i 0 (1+ i)))
@ -2603,7 +2602,7 @@
(props->sourcev source)) (props->sourcev source))
((and (vector? source) (= 3 (vector-length source))) ((and (vector? source) (= 3 (vector-length source)))
source) source)
(else (syntax-sourcev source))))) (else (syntax-source source)))))
(define/override (syntax->datum x) (define/override (syntax->datum x)
;; accepts any object, since syntax objects may consist partially ;; accepts any object, since syntax objects may consist partially
@ -3057,7 +3056,7 @@
(define call-with-include-port (define call-with-include-port
(let ((syntax-dirname (lambda (stx) (let ((syntax-dirname (lambda (stx)
(define src (syntax-source stx)) (define src (syntax-source stx))
(define filename (and src (assq-ref src 'filename))) (define filename (and src (vector-ref src 0)))
(and (string? filename) (and (string? filename)
(dirname filename))))) (dirname filename)))))
(lambda* (filename proc #:key (dirname (syntax-dirname filename))) (lambda* (filename proc #:key (dirname (syntax-dirname filename)))

4
module/srfi/srfi-64.scm
View file

@ -628,8 +628,8 @@ the @var{cleanup-form}. The latter shall be executed even if one of a
"Extract properties of syntax @var{form} and return them as a alist with "Extract properties of syntax @var{form} and return them as a alist with
keys compatible with Guile's SRFI-64 implementation." keys compatible with Guile's SRFI-64 implementation."
(let* ((source (syntax-source form)) (let* ((source (syntax-source form))
(file (and=> source (cut assq-ref <> 'filename))) (file (and source (vector-ref source 0)))
(line (and=> source (cut assq-ref <> 'line))) (line (and source (vector-ref source 1)))
;; I do not care about column. Tests are not nested enough. ;; I do not care about column. Tests are not nested enough.
(file-alist (if file (file-alist (if file
`((source-file . ,file)) `((source-file . ,file))

13
module/system/base/types.scm
View file

@ -454,14 +454,11 @@ using BACKEND."
(make-pointer address)) (make-pointer address))
(((_ & #x7f = %tc7-keyword) symbol) (((_ & #x7f = %tc7-keyword) symbol)
(symbol->keyword (cell->object symbol backend))) (symbol->keyword (cell->object symbol backend)))
(((_ & #x7f = %tc7-syntax) expression wrap module) (((_ & #x7f = %tc7-syntax) expression wrap module source)
(cond-expand (make-syntax (cell->object expression backend)
(guile-2.2 (cell->object wrap backend)
(make-syntax (cell->object expression backend) (cell->object module backend)
(cell->object wrap backend) (cell->object source backend)))
(cell->object module backend)))
(else
(inferior-object 'syntax address))))
(((_ & #x7f = %tc7-vm-continuation)) (((_ & #x7f = %tc7-vm-continuation))
(inferior-object 'vm-continuation address)) (inferior-object 'vm-continuation address))
(((_ & #x7f = %tc7-weak-set)) (((_ & #x7f = %tc7-weak-set))

13
module/system/syntax.scm
View file

@ -1,6 +1,6 @@
;;; Syntax utilities ;;; Syntax utilities
;;; Copyright (C) 2017, 2021 Free Software Foundation, Inc. ;;; Copyright (C) 2017, 2021, 2025 Free Software Foundation, Inc.
;;;; This library is free software; you can redistribute it and/or ;;;; This library is free software; you can redistribute it and/or
;;;; modify it under the terms of the GNU Lesser General Public ;;;; modify it under the terms of the GNU Lesser General Public
@ -24,14 +24,19 @@
syntax-local-binding syntax-local-binding
(%syntax-module . syntax-module) (%syntax-module . syntax-module)
syntax-locally-bound-identifiers syntax-locally-bound-identifiers
syntax-session-id syntax-session-id))
syntax-sourcev))
(begin-deprecated
(define-public (syntax-sourcev x)
(issue-deprecation-warning
"syntax-sourcev is deprecated. Use syntax-source instead.")
(syntax-source x)))
;; Used by syntax.c. ;; Used by syntax.c.
(define (print-syntax obj port) (define (print-syntax obj port)
;; FIXME: Use syntax->datum instad of syntax-expression, when ;; FIXME: Use syntax->datum instad of syntax-expression, when
;; syntax->datum can operate on new syntax objects. ;; syntax->datum can operate on new syntax objects.
(let ((src (syntax-sourcev obj))) (let ((src (syntax-source obj)))
(if src (if src
(format port "#<syntax:~a:~a:~a ~s>" (format port "#<syntax:~a:~a:~a ~s>"
(cond (cond

16
module/system/vm/assembler.scm
View file

@ -582,7 +582,7 @@ N-byte unit."
;; A list of (pos . source) pairs, indicating source information. POS ;; A list of (pos . source) pairs, indicating source information. POS
;; is relative to the beginning of the text section, and SOURCE is in ;; is relative to the beginning of the text section, and SOURCE is in
;; the same format that syntax-sourcev returns. ;; the same format that syntax-source returns.
;; ;;
(sources asm-sources set-asm-sources!) (sources asm-sources set-asm-sources!)
@ -1301,7 +1301,7 @@ table, its existing label is used directly."
(patch! 1 (syntax-expression obj)) (patch! 1 (syntax-expression obj))
(patch! 2 (syntax-wrap obj)) (patch! 2 (syntax-wrap obj))
(patch! 3 (syntax-module obj)) (patch! 3 (syntax-module obj))
(patch! 4 (syntax-sourcev obj))) (patch! 4 (syntax-source obj)))
((stringbuf? obj)) ((stringbuf? obj))
((static-procedure? obj) ((static-procedure? obj)
;; Special case, as we can't load the procedure's code using ;; Special case, as we can't load the procedure's code using
@ -1862,7 +1862,6 @@ should be .data or .rodata), and return the resulting linker object.
(define stringbuf-wide-flag #x400) (define stringbuf-wide-flag #x400)
(define tc7-syntax #x3d) (define tc7-syntax #x3d)
(define syntax-has-source-flag #x100)
(define tc7-program #x45) (define tc7-program #x45)
@ -2011,11 +2010,10 @@ should be .data or .rodata), and return the resulting linker object.
(write-placeholder asm buf pos)) (write-placeholder asm buf pos))
((syntax? obj) ((syntax? obj)
(let ((tag (logior tc7-syntax syntax-has-source-flag))) (case word-size
(case word-size ((4) (bytevector-u32-set! buf pos tc7-syntax endianness))
((4) (bytevector-u32-set! buf pos tag endianness)) ((8) (bytevector-u64-set! buf pos tc7-syntax endianness))
((8) (bytevector-u64-set! buf pos tag endianness)) (else (error "bad word size")))
(else (error "bad word size"))))
(write-constant-reference buf (+ pos (* 1 word-size)) (write-constant-reference buf (+ pos (* 1 word-size))
(syntax-expression obj)) (syntax-expression obj))
(write-constant-reference buf (+ pos (* 2 word-size)) (write-constant-reference buf (+ pos (* 2 word-size))
@ -2023,7 +2021,7 @@ should be .data or .rodata), and return the resulting linker object.
(write-constant-reference buf (+ pos (* 3 word-size)) (write-constant-reference buf (+ pos (* 3 word-size))
(syntax-module obj)) (syntax-module obj))
(write-constant-reference buf (+ pos (* 4 word-size)) (write-constant-reference buf (+ pos (* 4 word-size))
(syntax-sourcev obj))) (syntax-source obj)))
((number? obj) ((number? obj)
(write-placeholder asm buf pos)) (write-placeholder asm buf pos))

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

@ -1,6 +1,6 @@
;;;; reader.test --- Reader test. -*- coding: iso-8859-1; mode: scheme -*- ;;;; reader.test --- Reader test. -*- coding: iso-8859-1; mode: scheme -*-
;;;; ;;;;
;;;; Copyright (C) 1999, 2001-2003, 2007-2011, 2013-2015, 2020-2022 ;;;; Copyright (C) 1999, 2001-2003, 2007-2011, 2013-2015, 2020-2022, 2025
;;;; Free Software Foundation, Inc. ;;;; Free Software Foundation, Inc.
;;;; ;;;;
;;;; Jim Blandy <jimb@red-bean.com> ;;;; Jim Blandy <jimb@red-bean.com>
@ -558,7 +558,7 @@
read-syntax))) read-syntax)))
(pass-if-equal "syntax-source" (pass-if-equal "syntax-source"
'((filename . "sample.scm") (line . 2) (column . 3)) #("sample.scm" 2 3)
(syntax-source (syntax-source
(call-with-input-string "\ (call-with-input-string "\
;; first line ;; first line