mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
Syntax objects have "source" field
* libguile/syntax.c (scm_make_syntax): Add optional "source" argument. Note that this function is internal. (scm_syntax_source): New function, replacing definition in boot-9.scm. * libguile/syntax.h: Add new declarations. * module/ice-9/psyntax-pp.scm: * module/ice-9/psyntax.scm (source-annotation): For syntax objects, the source annotation comes direct from the syntax object. * module/system/vm/assembler.scm (link-data, intern-constant): Write 5-word syntax objects.
This commit is contained in:
Andy Wingo
parent
064b394d5a
commit
2edf91d51c
6 changed files with 73 additions and 31 deletions
|
|
@ -1,4 +1,4 @@
|
|||
/* Copyright 2017-2018
|
||||
/* Copyright 2017-2018,2021
|
||||
Free Software Foundation, Inc.
|
||||
|
||||
This file is part of Guile.
|
||||
|
|
@ -28,7 +28,9 @@
|
|||
#include "gsubr.h"
|
||||
#include "keywords.h"
|
||||
#include "modules.h"
|
||||
#include "pairs.h"
|
||||
#include "ports.h"
|
||||
#include "srcprop.h"
|
||||
#include "threads.h"
|
||||
#include "variable.h"
|
||||
|
||||
|
|
@ -37,6 +39,22 @@
|
|||
|
||||
|
||||
|
||||
/* 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,
|
||||
EXPR_WORD,
|
||||
WRAP_WORD,
|
||||
MODULE_WORD,
|
||||
SOURCE_WORD,
|
||||
WORD_COUNT
|
||||
};
|
||||
|
||||
static int
|
||||
scm_is_syntax (SCM x)
|
||||
{
|
||||
|
|
@ -56,13 +74,23 @@ SCM_DEFINE (scm_syntax_p, "syntax?", 1, 0, 0,
|
|||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_make_syntax, "make-syntax", 3, 0, 0,
|
||||
(SCM exp, SCM wrap, SCM module),
|
||||
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
|
||||
{
|
||||
return scm_double_cell (scm_tc7_syntax, SCM_UNPACK (exp),
|
||||
SCM_UNPACK (wrap), SCM_UNPACK (module));
|
||||
if (SCM_UNBNDP (source))
|
||||
source = scm_source_properties (exp);
|
||||
if (!scm_is_pair (source))
|
||||
source = SCM_BOOL_F;
|
||||
|
||||
SCM ret = scm_words (scm_tc7_syntax | HAS_SOURCE_WORD_FLAG, 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);
|
||||
SCM_SET_CELL_OBJECT (ret, SOURCE_WORD, source);
|
||||
|
||||
return ret;
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
|
@ -72,7 +100,7 @@ SCM_DEFINE (scm_syntax_expression, "syntax-expression", 1, 0, 0,
|
|||
#define FUNC_NAME s_scm_syntax_expression
|
||||
{
|
||||
SCM_VALIDATE_SYNTAX (1, obj);
|
||||
return SCM_CELL_OBJECT_1 (obj);
|
||||
return SCM_CELL_OBJECT (obj, EXPR_WORD);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
|
@ -82,7 +110,7 @@ SCM_DEFINE (scm_syntax_wrap, "syntax-wrap", 1, 0, 0,
|
|||
#define FUNC_NAME s_scm_syntax_wrap
|
||||
{
|
||||
SCM_VALIDATE_SYNTAX (1, obj);
|
||||
return SCM_CELL_OBJECT_2 (obj);
|
||||
return SCM_CELL_OBJECT (obj, WRAP_WORD);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
|
|
@ -92,7 +120,19 @@ SCM_DEFINE (scm_syntax_module, "syntax-module", 1, 0, 0,
|
|||
#define FUNC_NAME s_scm_syntax_module
|
||||
{
|
||||
SCM_VALIDATE_SYNTAX (1, obj);
|
||||
return SCM_CELL_OBJECT_3 (obj);
|
||||
return SCM_CELL_OBJECT (obj, MODULE_WORD);
|
||||
}
|
||||
#undef FUNC_NAME
|
||||
|
||||
SCM_DEFINE (scm_syntax_source, "syntax-source", 1, 0, 0,
|
||||
(SCM obj),
|
||||
"Return the source location information for syntax object @var{obj}.")
|
||||
#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;
|
||||
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
|
||||
/* Copyright 2017-2018,2021
|
||||
Free Software Foundation, Inc.
|
||||
|
||||
This file is part of Guile.
|
||||
|
|
@ -23,10 +23,11 @@
|
|||
#include "libguile/scm.h"
|
||||
|
||||
SCM_INTERNAL SCM scm_syntax_p (SCM obj);
|
||||
SCM_INTERNAL SCM scm_make_syntax (SCM exp, SCM wrap, SCM module);
|
||||
SCM_INTERNAL SCM scm_make_syntax (SCM exp, SCM wrap, SCM module, SCM source);
|
||||
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 void scm_i_syntax_print (SCM obj, SCM port,
|
||||
scm_print_state *pstate);
|
||||
|
|
|
|||
|
|
@ -379,7 +379,6 @@ If returning early, return the return value of F."
|
|||
(define syntax-violation #f)
|
||||
(define datum->syntax #f)
|
||||
(define syntax->datum #f)
|
||||
(define syntax-source #f)
|
||||
(define identifier? #f)
|
||||
(define generate-temporaries #f)
|
||||
(define bound-identifier=? #f)
|
||||
|
|
|
|||
|
|
@ -236,8 +236,10 @@
|
|||
(make-letrec src in-order? ids vars val-exps body-exp)))))
|
||||
(source-annotation
|
||||
(lambda (x)
|
||||
(let ((props (source-properties (if (syntax? x) (syntax-expression x) x))))
|
||||
(and (pair? props) props))))
|
||||
(if (syntax? x)
|
||||
(syntax-source x)
|
||||
(let ((props (source-properties x)))
|
||||
(and (pair? props) props)))))
|
||||
(extend-env
|
||||
(lambda (labels bindings r)
|
||||
(if (null? labels)
|
||||
|
|
@ -2416,7 +2418,6 @@
|
|||
(lambda (id datum)
|
||||
(make-syntax datum (syntax-wrap id) (syntax-module id))))
|
||||
(set! syntax->datum (lambda (x) (strip x '(()))))
|
||||
(set! syntax-source (lambda (x) (source-annotation x)))
|
||||
(set! generate-temporaries
|
||||
(lambda (ls)
|
||||
(let ((x ls))
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;;; -*-scheme-*-
|
||||
;;;;
|
||||
;;;; Copyright (C) 2001, 2003, 2006, 2009, 2010-2020
|
||||
;;;; Copyright (C) 2001, 2003, 2006, 2009, 2010-2021
|
||||
;;;; Free Software Foundation, Inc.
|
||||
;;;;
|
||||
;;;; This library is free software; you can redistribute it and/or
|
||||
|
|
@ -454,11 +454,10 @@
|
|||
|
||||
(define source-annotation
|
||||
(lambda (x)
|
||||
(let ((props (source-properties
|
||||
(if (syntax? x)
|
||||
(syntax-expression x)
|
||||
x))))
|
||||
(and (pair? props) props))))
|
||||
(if (syntax? x)
|
||||
(syntax-source x)
|
||||
(let ((props (source-properties x)))
|
||||
(and (pair? props) props)))))
|
||||
|
||||
(define-syntax-rule (arg-check pred? e who)
|
||||
(let ((x e))
|
||||
|
|
@ -2769,9 +2768,6 @@
|
|||
(lambda (x)
|
||||
(strip x empty-wrap)))
|
||||
|
||||
(set! syntax-source
|
||||
(lambda (x) (source-annotation x)))
|
||||
|
||||
(set! generate-temporaries
|
||||
(lambda (ls)
|
||||
(arg-check list? ls 'generate-temporaries)
|
||||
|
|
|
|||
|
|
@ -1,6 +1,6 @@
|
|||
;;; Guile bytecode assembler
|
||||
|
||||
;;; Copyright (C) 2001, 2009-2020 Free Software Foundation, Inc.
|
||||
;;; Copyright (C) 2001, 2009-2021 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
|
||||
|
|
@ -1272,7 +1272,8 @@ table, its existing label is used directly."
|
|||
((syntax? obj)
|
||||
(append (field label 1 (syntax-expression obj))
|
||||
(field label 2 (syntax-wrap obj))
|
||||
(field label 3 (syntax-module obj))))
|
||||
(field label 3 (syntax-module obj))
|
||||
(field label 4 (syntax-source obj))))
|
||||
((stringbuf? obj) '())
|
||||
((static-procedure? obj)
|
||||
`((static-patch! ,label 1 ,(static-procedure-code obj))))
|
||||
|
|
@ -1772,6 +1773,7 @@ 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)
|
||||
|
||||
|
|
@ -1804,7 +1806,7 @@ should be .data or .rodata), and return the resulting linker object.
|
|||
((simple-vector? x)
|
||||
(* (1+ (vector-length x)) word-size))
|
||||
((syntax? x)
|
||||
(* 4 word-size))
|
||||
(* 5 word-size))
|
||||
((jit-data? x)
|
||||
(case word-size
|
||||
((4) (+ word-size (* 4 3)))
|
||||
|
|
@ -1920,16 +1922,19 @@ should be .data or .rodata), and return the resulting linker object.
|
|||
(write-placeholder asm buf pos))
|
||||
|
||||
((syntax? obj)
|
||||
(case 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")))
|
||||
(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"))))
|
||||
(write-constant-reference buf (+ pos (* 1 word-size))
|
||||
(syntax-expression obj))
|
||||
(write-constant-reference buf (+ pos (* 2 word-size))
|
||||
(syntax-wrap obj))
|
||||
(write-constant-reference buf (+ pos (* 3 word-size))
|
||||
(syntax-module obj)))
|
||||
(syntax-module obj))
|
||||
(write-constant-reference buf (+ pos (* 4 word-size))
|
||||
(syntax-source obj)))
|
||||
|
||||
((number? obj)
|
||||
(write-placeholder asm buf pos))
|
||||
|
|
|
|||
Loading…
Add table
Add a link
Reference in a new issue