mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-12 14:50:19 +02:00
syntax-source returns a vector
* 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
parent
71d112cdde
commit
b6b6f62548
10 changed files with 120 additions and 163 deletions
|
|
@ -1,4 +1,4 @@
|
|||
/* Copyright 2017-2018,2021
|
||||
/* Copyright 2017-2018,2021,2025
|
||||
Free Software Foundation, Inc.
|
||||
|
||||
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
|
||||
{
|
||||
TAG_WORD,
|
||||
|
|
@ -76,40 +70,17 @@ SCM_DEFINE (scm_syntax_p, "syntax?", 1, 0, 0,
|
|||
}
|
||||
#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 exp, SCM wrap, SCM module, SCM source),
|
||||
"Make a new syntax object.")
|
||||
#define FUNC_NAME s_scm_make_syntax
|
||||
{
|
||||
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;
|
||||
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, WRAP_WORD, wrap);
|
||||
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
|
||||
{
|
||||
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_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;
|
||||
return SCM_CELL_OBJECT (obj, SOURCE_WORD);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
|
|
|||
|
|
@ -1,7 +1,7 @@
|
|||
#ifndef SCM_SYNTAX_H
|
||||
#define SCM_SYNTAX_H
|
||||
|
||||
/* Copyright 2017-2018,2021
|
||||
/* Copyright 2017-2018,2021,2025
|
||||
Free Software Foundation, Inc.
|
||||
|
||||
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_module (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_print_state *pstate);
|
||||
|
|
|
|||
|
|
@ -554,8 +554,7 @@ If returning early, return the return value of F."
|
|||
warning)
|
||||
type
|
||||
(or (syntax-source datum)
|
||||
(syntax-source #'test)
|
||||
'())
|
||||
(syntax-source #'test))
|
||||
raw
|
||||
(syntax->datum clause)
|
||||
(syntax->datum whole-expr)))
|
||||
|
|
@ -688,8 +687,17 @@ If returning early, return the return value of F."
|
|||
(lambda (x)
|
||||
(syntax-case x ()
|
||||
((_)
|
||||
(with-syntax ((s (datum->syntax x (syntax-source x))))
|
||||
#''s)))))
|
||||
(cond
|
||||
((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
|
||||
;; 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
|
||||
the (current-filename) form appears in. Expands to #f if this
|
||||
information is unavailable."
|
||||
(false-if-exception
|
||||
(canonicalize-path (assq-ref (syntax-source x) 'filename)))))
|
||||
(and=> (syntax-source x)
|
||||
(lambda (v)
|
||||
(and=> (vector-ref v 0)
|
||||
(lambda (filename)
|
||||
(false-if-exception (canonicalize-path filename))))))))
|
||||
|
||||
(define-syntax-rule (define-once sym val)
|
||||
(define sym
|
||||
|
|
@ -3838,9 +3849,11 @@ but it fails to load."
|
|||
;; this hack is to work around a case in which
|
||||
;; port-filename returns a symbol (`socket') for
|
||||
;; sockets.
|
||||
(filename (let ((f (assq-ref (or (syntax-source x) '())
|
||||
'filename)))
|
||||
(and (string? f) f))))
|
||||
(filename (and=> (syntax-source x)
|
||||
(lambda (v)
|
||||
(and=> (vector-ref v 0)
|
||||
(lambda (f)
|
||||
(and (string? f) f)))))))
|
||||
#'(eval-when (expand load eval)
|
||||
(let ((m (define-module* '(name name* ...)
|
||||
#:filename filename quoted-arg ...)))
|
||||
|
|
@ -4327,7 +4340,7 @@ when none is available, reading FILE-NAME with READER."
|
|||
(make-variable-transformer
|
||||
(lambda (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))))
|
||||
;; A module that uses `load' is not declarative.
|
||||
(when (module-declarative? (current-module))
|
||||
|
|
@ -4665,8 +4678,7 @@ R7RS."
|
|||
make-syntax
|
||||
syntax-expression
|
||||
syntax-wrap
|
||||
syntax-module
|
||||
syntax-sourcev)))
|
||||
syntax-module)))
|
||||
|
||||
|
||||
|
||||
|
|
|
|||
|
|
@ -5,8 +5,7 @@
|
|||
(make-syntax (module-ref (current-module) 'make-syntax))
|
||||
(syntax-expression (module-ref (current-module) 'syntax-expression))
|
||||
(syntax-wrap (module-ref (current-module) 'syntax-wrap))
|
||||
(syntax-module (module-ref (current-module) 'syntax-module))
|
||||
(syntax-sourcev (module-ref (current-module) 'syntax-sourcev)))
|
||||
(syntax-module (module-ref (current-module) 'syntax-module)))
|
||||
(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-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)))))
|
||||
(gen-lexical (lambda (id) (module-gensym (symbol->string id))))
|
||||
(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-value (lambda (x) (cdr x)))
|
||||
(null-env '())
|
||||
|
|
@ -663,8 +662,7 @@
|
|||
(if (null? v) #f (fk)))))
|
||||
(wrap (lambda (x w defmod) (source-wrap x w #f defmod)))
|
||||
(wrap-syntax
|
||||
(lambda (x w defmod)
|
||||
(make-syntax (syntax-expression x) w (or (syntax-module x) defmod) (syntax-sourcev x))))
|
||||
(lambda (x w defmod) (make-syntax (syntax-expression x) w (or (syntax-module x) defmod) (syntax-source x))))
|
||||
(source-wrap
|
||||
(lambda (x w s defmod)
|
||||
(cond
|
||||
|
|
@ -1137,11 +1135,11 @@
|
|||
(source-wrap e w (wrap-subst w) mod)
|
||||
x))
|
||||
(else (decorate-source x))))))
|
||||
(let* ((t-680b775fb37a463-c32 transformer-environment)
|
||||
(t-680b775fb37a463-c33 (lambda (k) (k e r w s rib mod))))
|
||||
(let* ((t-680b775fb37a463-c30 transformer-environment)
|
||||
(t-680b775fb37a463-c31 (lambda (k) (k e r w s rib mod))))
|
||||
(with-fluid*
|
||||
t-680b775fb37a463-c32
|
||||
t-680b775fb37a463-c33
|
||||
t-680b775fb37a463-c30
|
||||
t-680b775fb37a463-c31
|
||||
(lambda () (rebuild-macro-output (p (source-wrap e (anti-mark w) s mod)) (new-mark))))))))
|
||||
(expand-body
|
||||
(lambda (body outer-form r w mod)
|
||||
|
|
@ -1672,11 +1670,11 @@
|
|||
s
|
||||
mod
|
||||
get-formals
|
||||
(map (lambda (tmp-680b775fb37a463-ebb
|
||||
tmp-680b775fb37a463-eba
|
||||
tmp-680b775fb37a463-eb9)
|
||||
(cons tmp-680b775fb37a463-eb9
|
||||
(cons tmp-680b775fb37a463-eba tmp-680b775fb37a463-ebb)))
|
||||
(map (lambda (tmp-680b775fb37a463-eb9
|
||||
tmp-680b775fb37a463-eb8
|
||||
tmp-680b775fb37a463-eb7)
|
||||
(cons tmp-680b775fb37a463-eb7
|
||||
(cons tmp-680b775fb37a463-eb8 tmp-680b775fb37a463-eb9)))
|
||||
e2*
|
||||
e1*
|
||||
args*)))
|
||||
|
|
@ -1954,11 +1952,9 @@
|
|||
(apply (lambda (docstring args e1 e2)
|
||||
(build-it
|
||||
(list (cons 'documentation (syntax->datum docstring)))
|
||||
(map (lambda (tmp-680b775fb37a463-112b
|
||||
tmp-680b775fb37a463-112a
|
||||
tmp-680b775fb37a463)
|
||||
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
|
||||
(cons tmp-680b775fb37a463
|
||||
(cons tmp-680b775fb37a463-112a tmp-680b775fb37a463-112b)))
|
||||
(cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2)))
|
||||
e2
|
||||
e1
|
||||
args)))
|
||||
|
|
@ -1976,9 +1972,8 @@
|
|||
(apply (lambda (args e1 e2)
|
||||
(build-it
|
||||
'()
|
||||
(map (lambda (tmp-680b775fb37a463-114b tmp-680b775fb37a463-114a tmp-680b775fb37a463)
|
||||
(cons tmp-680b775fb37a463
|
||||
(cons tmp-680b775fb37a463-114a tmp-680b775fb37a463-114b)))
|
||||
(map (lambda (tmp-680b775fb37a463-2 tmp-680b775fb37a463-1 tmp-680b775fb37a463)
|
||||
(cons tmp-680b775fb37a463 (cons tmp-680b775fb37a463-1 tmp-680b775fb37a463-2)))
|
||||
e2
|
||||
e1
|
||||
args)))
|
||||
|
|
@ -1988,9 +1983,11 @@
|
|||
(apply (lambda (docstring args e1 e2)
|
||||
(build-it
|
||||
(list (cons 'documentation (syntax->datum docstring)))
|
||||
(map (lambda (tmp-680b775fb37a463-1 tmp-680b775fb37a463 tmp-680b775fb37a463-115f)
|
||||
(cons tmp-680b775fb37a463-115f
|
||||
(cons tmp-680b775fb37a463 tmp-680b775fb37a463-1)))
|
||||
(map (lambda (tmp-680b775fb37a463-115f
|
||||
tmp-680b775fb37a463-115e
|
||||
tmp-680b775fb37a463-115d)
|
||||
(cons tmp-680b775fb37a463-115d
|
||||
(cons tmp-680b775fb37a463-115e tmp-680b775fb37a463-115f)))
|
||||
e2
|
||||
e1
|
||||
args)))
|
||||
|
|
@ -2007,7 +2004,7 @@
|
|||
'#{ $sc-ellipsis }#
|
||||
(syntax-wrap dots)
|
||||
(syntax-module dots)
|
||||
(syntax-sourcev dots)))))
|
||||
(syntax-source dots)))))
|
||||
(let ((ids (list id))
|
||||
(labels (list (gen-label)))
|
||||
(bindings (list (cons 'ellipsis (source-wrap dots w s mod)))))
|
||||
|
|
@ -2157,7 +2154,7 @@
|
|||
(remodulate (syntax-expression x) mod)
|
||||
(syntax-wrap x)
|
||||
mod
|
||||
(syntax-sourcev x)))
|
||||
(syntax-source x)))
|
||||
((vector? x)
|
||||
(let* ((n (vector-length x)) (v (make-vector n)))
|
||||
(let loop ((i 0))
|
||||
|
|
@ -2456,7 +2453,7 @@
|
|||
((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)))))))
|
||||
(else (syntax-source source)))))))
|
||||
(set! syntax->datum (lambda (x) (strip x)))
|
||||
(set! generate-temporaries
|
||||
(lambda (ls)
|
||||
|
|
@ -2793,9 +2790,9 @@
|
|||
#f
|
||||
k
|
||||
'()
|
||||
(map (lambda (tmp-680b775fb37a463-143f tmp-680b775fb37a463-143e tmp-680b775fb37a463-143d)
|
||||
(list (cons tmp-680b775fb37a463-143d tmp-680b775fb37a463-143e)
|
||||
tmp-680b775fb37a463-143f))
|
||||
(map (lambda (tmp-680b775fb37a463-143d tmp-680b775fb37a463-143c tmp-680b775fb37a463-143b)
|
||||
(list (cons tmp-680b775fb37a463-143b tmp-680b775fb37a463-143c)
|
||||
tmp-680b775fb37a463-143d))
|
||||
template
|
||||
pattern
|
||||
keyword)))
|
||||
|
|
@ -2823,9 +2820,11 @@
|
|||
dots
|
||||
k
|
||||
'()
|
||||
(map (lambda (tmp-680b775fb37a463-1 tmp-680b775fb37a463 tmp-680b775fb37a463-146f)
|
||||
(list (cons tmp-680b775fb37a463-146f tmp-680b775fb37a463)
|
||||
tmp-680b775fb37a463-1))
|
||||
(map (lambda (tmp-680b775fb37a463-146f
|
||||
tmp-680b775fb37a463-146e
|
||||
tmp-680b775fb37a463-146d)
|
||||
(list (cons tmp-680b775fb37a463-146d tmp-680b775fb37a463-146e)
|
||||
tmp-680b775fb37a463-146f))
|
||||
template
|
||||
pattern
|
||||
keyword)))
|
||||
|
|
@ -2841,11 +2840,11 @@
|
|||
dots
|
||||
k
|
||||
(list docstring)
|
||||
(map (lambda (tmp-680b775fb37a463
|
||||
tmp-680b775fb37a463-148f
|
||||
tmp-680b775fb37a463-148e)
|
||||
(list (cons tmp-680b775fb37a463-148e tmp-680b775fb37a463-148f)
|
||||
tmp-680b775fb37a463))
|
||||
(map (lambda (tmp-680b775fb37a463-148e
|
||||
tmp-680b775fb37a463-148d
|
||||
tmp-680b775fb37a463-148c)
|
||||
(list (cons tmp-680b775fb37a463-148c tmp-680b775fb37a463-148d)
|
||||
tmp-680b775fb37a463-148e))
|
||||
template
|
||||
pattern
|
||||
keyword)))
|
||||
|
|
@ -2973,9 +2972,9 @@
|
|||
(apply (lambda (p)
|
||||
(if (= lev 0)
|
||||
(quasilist*
|
||||
(map (lambda (tmp-680b775fb37a463-153d)
|
||||
(map (lambda (tmp-680b775fb37a463-153b)
|
||||
(list "value"
|
||||
tmp-680b775fb37a463-153d))
|
||||
tmp-680b775fb37a463-153b))
|
||||
p)
|
||||
(quasi q lev))
|
||||
(quasicons
|
||||
|
|
@ -3060,8 +3059,8 @@
|
|||
(apply (lambda (p)
|
||||
(if (= lev 0)
|
||||
(quasiappend
|
||||
(map (lambda (tmp-680b775fb37a463-155d)
|
||||
(list "value" tmp-680b775fb37a463-155d))
|
||||
(map (lambda (tmp-680b775fb37a463-155b)
|
||||
(list "value" tmp-680b775fb37a463-155b))
|
||||
p)
|
||||
(vquasi q lev))
|
||||
(quasicons
|
||||
|
|
@ -3143,8 +3142,8 @@
|
|||
(let ((tmp-1 ls))
|
||||
(let ((tmp ($sc-dispatch tmp-1 'each-any)))
|
||||
(if tmp
|
||||
(apply (lambda (t-680b775fb37a463-15a6)
|
||||
(cons "vector" t-680b775fb37a463-15a6))
|
||||
(apply (lambda (t-680b775fb37a463-15a4)
|
||||
(cons "vector" t-680b775fb37a463-15a4))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
|
|
@ -3154,8 +3153,8 @@
|
|||
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") each-any))))
|
||||
(if tmp-1
|
||||
(apply (lambda (y)
|
||||
(k (map (lambda (tmp-680b775fb37a463-15b2)
|
||||
(list "quote" tmp-680b775fb37a463-15b2))
|
||||
(k (map (lambda (tmp-680b775fb37a463-15b0)
|
||||
(list "quote" tmp-680b775fb37a463-15b0))
|
||||
y)))
|
||||
tmp-1)
|
||||
(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)
|
||||
(let ((else tmp))
|
||||
(let ((tmp x))
|
||||
(let ((t-680b775fb37a463-15c1 tmp))
|
||||
(list "list->vector" t-680b775fb37a463-15c1)))))))))))))))))
|
||||
(let ((t-680b775fb37a463-15bf tmp))
|
||||
(list "list->vector" t-680b775fb37a463-15bf)))))))))))))))))
|
||||
(emit (lambda (x)
|
||||
(let ((tmp x))
|
||||
(let ((tmp-1 ($sc-dispatch tmp '(#(atom "quote") any))))
|
||||
|
|
@ -3179,9 +3178,9 @@
|
|||
(let ((tmp-1 (map emit x)))
|
||||
(let ((tmp ($sc-dispatch tmp-1 'each-any)))
|
||||
(if tmp
|
||||
(apply (lambda (t-680b775fb37a463-15d0)
|
||||
(apply (lambda (t-680b775fb37a463-15ce)
|
||||
(cons (make-syntax 'list '((top)) '(hygiene guile))
|
||||
t-680b775fb37a463-15d0))
|
||||
t-680b775fb37a463-15ce))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
|
|
@ -3197,14 +3196,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-15e4
|
||||
t-680b775fb37a463-15e3)
|
||||
(apply (lambda (t-680b775fb37a463-15e2
|
||||
t-680b775fb37a463-15e1)
|
||||
(list (make-syntax
|
||||
'cons
|
||||
'((top))
|
||||
'(hygiene guile))
|
||||
t-680b775fb37a463-15e4
|
||||
t-680b775fb37a463-15e3))
|
||||
t-680b775fb37a463-15e2
|
||||
t-680b775fb37a463-15e1))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
|
|
@ -3217,12 +3216,12 @@
|
|||
(let ((tmp-1 (map emit x)))
|
||||
(let ((tmp ($sc-dispatch tmp-1 'each-any)))
|
||||
(if tmp
|
||||
(apply (lambda (t-680b775fb37a463-15f0)
|
||||
(apply (lambda (t-680b775fb37a463-15ee)
|
||||
(cons (make-syntax
|
||||
'append
|
||||
'((top))
|
||||
'(hygiene guile))
|
||||
t-680b775fb37a463-15f0))
|
||||
t-680b775fb37a463-15ee))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
|
|
@ -3235,12 +3234,12 @@
|
|||
(let ((tmp-1 (map emit x)))
|
||||
(let ((tmp ($sc-dispatch tmp-1 'each-any)))
|
||||
(if tmp
|
||||
(apply (lambda (t-680b775fb37a463-15fc)
|
||||
(apply (lambda (t-680b775fb37a463-15fa)
|
||||
(cons (make-syntax
|
||||
'vector
|
||||
'((top))
|
||||
'(hygiene guile))
|
||||
t-680b775fb37a463-15fc))
|
||||
t-680b775fb37a463-15fa))
|
||||
tmp)
|
||||
(syntax-violation
|
||||
#f
|
||||
|
|
@ -3275,7 +3274,7 @@
|
|||
(define call-with-include-port
|
||||
(let ((syntax-dirname
|
||||
(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)))))
|
||||
(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."
|
||||
|
|
|
|||
|
|
@ -74,8 +74,7 @@
|
|||
(make-syntax (module-ref (current-module) 'make-syntax))
|
||||
(syntax-expression (module-ref (current-module) 'syntax-expression))
|
||||
(syntax-wrap (module-ref (current-module) 'syntax-wrap))
|
||||
(syntax-module (module-ref (current-module) 'syntax-module))
|
||||
(syntax-sourcev (module-ref (current-module) 'syntax-sourcev)))
|
||||
(syntax-module (module-ref (current-module) 'syntax-module)))
|
||||
|
||||
(define-syntax define-expansion-constructors
|
||||
(lambda (x)
|
||||
|
|
@ -304,7 +303,7 @@
|
|||
(define no-source #f)
|
||||
|
||||
(define (source-annotation x)
|
||||
(and (syntax? x) (syntax-sourcev x)))
|
||||
(and (syntax? x) (syntax-source x)))
|
||||
|
||||
(define-syntax-rule (arg-check pred? e who)
|
||||
(let ((x e))
|
||||
|
|
@ -889,7 +888,7 @@
|
|||
(make-syntax (syntax-expression x)
|
||||
w
|
||||
(or (syntax-module x) defmod)
|
||||
(syntax-sourcev x)))
|
||||
(syntax-source x)))
|
||||
(define (source-wrap x w s defmod)
|
||||
(cond
|
||||
((and (null? (wrap-marks w))
|
||||
|
|
@ -2165,7 +2164,7 @@
|
|||
(make-syntax '#{ $sc-ellipsis }#
|
||||
(syntax-wrap #'dots)
|
||||
(syntax-module #'dots)
|
||||
(syntax-sourcev #'dots)))))
|
||||
(syntax-source #'dots)))))
|
||||
(let ((ids (list id))
|
||||
(labels (list (gen-label)))
|
||||
(bindings (list (make-binding 'ellipsis (source-wrap #'dots w s mod)))))
|
||||
|
|
@ -2313,7 +2312,7 @@
|
|||
(syntax-wrap x)
|
||||
;; hither the remodulation
|
||||
mod
|
||||
(syntax-sourcev x)))
|
||||
(syntax-source x)))
|
||||
((vector? x)
|
||||
(let* ((n (vector-length x)) (v (make-vector n)))
|
||||
(do ((i 0 (1+ i)))
|
||||
|
|
@ -2603,7 +2602,7 @@
|
|||
(props->sourcev source))
|
||||
((and (vector? source) (= 3 (vector-length source)))
|
||||
source)
|
||||
(else (syntax-sourcev source)))))
|
||||
(else (syntax-source source)))))
|
||||
|
||||
(define/override (syntax->datum x)
|
||||
;; accepts any object, since syntax objects may consist partially
|
||||
|
|
@ -3057,7 +3056,7 @@
|
|||
(define call-with-include-port
|
||||
(let ((syntax-dirname (lambda (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)
|
||||
(dirname filename)))))
|
||||
(lambda* (filename proc #:key (dirname (syntax-dirname filename)))
|
||||
|
|
|
|||
|
|
@ -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
|
||||
keys compatible with Guile's SRFI-64 implementation."
|
||||
(let* ((source (syntax-source form))
|
||||
(file (and=> source (cut assq-ref <> 'filename)))
|
||||
(line (and=> source (cut assq-ref <> 'line)))
|
||||
(file (and source (vector-ref source 0)))
|
||||
(line (and source (vector-ref source 1)))
|
||||
;; I do not care about column. Tests are not nested enough.
|
||||
(file-alist (if file
|
||||
`((source-file . ,file))
|
||||
|
|
|
|||
|
|
@ -454,14 +454,11 @@ using BACKEND."
|
|||
(make-pointer address))
|
||||
(((_ & #x7f = %tc7-keyword) symbol)
|
||||
(symbol->keyword (cell->object symbol backend)))
|
||||
(((_ & #x7f = %tc7-syntax) expression wrap module)
|
||||
(cond-expand
|
||||
(guile-2.2
|
||||
(((_ & #x7f = %tc7-syntax) expression wrap module source)
|
||||
(make-syntax (cell->object expression backend)
|
||||
(cell->object wrap backend)
|
||||
(cell->object module backend)))
|
||||
(else
|
||||
(inferior-object 'syntax address))))
|
||||
(cell->object module backend)
|
||||
(cell->object source backend)))
|
||||
(((_ & #x7f = %tc7-vm-continuation))
|
||||
(inferior-object 'vm-continuation address))
|
||||
(((_ & #x7f = %tc7-weak-set))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; 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
|
||||
;;;; modify it under the terms of the GNU Lesser General Public
|
||||
|
|
@ -24,14 +24,19 @@
|
|||
syntax-local-binding
|
||||
(%syntax-module . syntax-module)
|
||||
syntax-locally-bound-identifiers
|
||||
syntax-session-id
|
||||
syntax-sourcev))
|
||||
syntax-session-id))
|
||||
|
||||
(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.
|
||||
(define (print-syntax obj port)
|
||||
;; FIXME: Use syntax->datum instad of syntax-expression, when
|
||||
;; syntax->datum can operate on new syntax objects.
|
||||
(let ((src (syntax-sourcev obj)))
|
||||
(let ((src (syntax-source obj)))
|
||||
(if src
|
||||
(format port "#<syntax:~a:~a:~a ~s>"
|
||||
(cond
|
||||
|
|
|
|||
|
|
@ -582,7 +582,7 @@ N-byte unit."
|
|||
|
||||
;; A list of (pos . source) pairs, indicating source information. POS
|
||||
;; 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!)
|
||||
|
||||
|
|
@ -1301,7 +1301,7 @@ table, its existing label is used directly."
|
|||
(patch! 1 (syntax-expression obj))
|
||||
(patch! 2 (syntax-wrap obj))
|
||||
(patch! 3 (syntax-module obj))
|
||||
(patch! 4 (syntax-sourcev obj)))
|
||||
(patch! 4 (syntax-source obj)))
|
||||
((stringbuf? obj))
|
||||
((static-procedure? obj)
|
||||
;; 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 tc7-syntax #x3d)
|
||||
(define syntax-has-source-flag #x100)
|
||||
|
||||
(define tc7-program #x45)
|
||||
|
||||
|
|
@ -2011,11 +2010,10 @@ should be .data or .rodata), and return the resulting linker object.
|
|||
(write-placeholder asm buf pos))
|
||||
|
||||
((syntax? obj)
|
||||
(let ((tag (logior tc7-syntax syntax-has-source-flag)))
|
||||
(case word-size
|
||||
((4) (bytevector-u32-set! buf pos tag endianness))
|
||||
((8) (bytevector-u64-set! buf pos tag endianness))
|
||||
(else (error "bad word size"))))
|
||||
((4) (bytevector-u32-set! buf pos tc7-syntax endianness))
|
||||
((8) (bytevector-u64-set! buf pos tc7-syntax endianness))
|
||||
(else (error "bad word size")))
|
||||
(write-constant-reference buf (+ pos (* 1 word-size))
|
||||
(syntax-expression obj))
|
||||
(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))
|
||||
(syntax-module obj))
|
||||
(write-constant-reference buf (+ pos (* 4 word-size))
|
||||
(syntax-sourcev obj)))
|
||||
(syntax-source obj)))
|
||||
|
||||
((number? obj)
|
||||
(write-placeholder asm buf pos))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;;; 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.
|
||||
;;;;
|
||||
;;;; Jim Blandy <jimb@red-bean.com>
|
||||
|
|
@ -558,7 +558,7 @@
|
|||
read-syntax)))
|
||||
|
||||
(pass-if-equal "syntax-source"
|
||||
'((filename . "sample.scm") (line . 2) (column . 3))
|
||||
#("sample.scm" 2 3)
|
||||
(syntax-source
|
||||
(call-with-input-string "\
|
||||
;; first line
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue