[Date Prev][Date Next][Thread Prev][Thread Next][Date Index][Thread Index]
[Guile-commits] 02/04: Syntax objects have "source" field
|
From: |
Andy Wingo |
|
Subject: |
[Guile-commits] 02/04: Syntax objects have "source" field |
|
Date: |
Sun, 21 Feb 2021 05:15:15 -0500 (EST) |
wingo pushed a commit to branch master
in repository guile.
commit 2edf91d51c39891e7dcb2de7af3788597816124e
Author: Andy Wingo <wingo@pobox.com>
AuthorDate: Sat Feb 20 20:19:34 2021 +0100
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.
---
libguile/syntax.c | 56 ++++++++++++++++++++++++++++++++++++------
libguile/syntax.h | 5 ++--
module/ice-9/boot-9.scm | 1 -
module/ice-9/psyntax-pp.scm | 7 +++---
module/ice-9/psyntax.scm | 14 ++++-------
module/system/vm/assembler.scm | 21 ++++++++++------
6 files changed, 73 insertions(+), 31 deletions(-)
diff --git a/libguile/syntax.c b/libguile/syntax.c
index 2da4e39..649e364 100644
--- a/libguile/syntax.c
+++ b/libguile/syntax.c
@@ -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
diff --git a/libguile/syntax.h b/libguile/syntax.h
index 16229f6..8a98c1d 100644
--- a/libguile/syntax.h
+++ b/libguile/syntax.h
@@ -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);
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 89595f3..67d84ae 100644
--- a/module/ice-9/boot-9.scm
+++ b/module/ice-9/boot-9.scm
@@ -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)
diff --git a/module/ice-9/psyntax-pp.scm b/module/ice-9/psyntax-pp.scm
index 9575825..3732d5a 100644
--- a/module/ice-9/psyntax-pp.scm
+++ b/module/ice-9/psyntax-pp.scm
@@ -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))
diff --git a/module/ice-9/psyntax.scm b/module/ice-9/psyntax.scm
index b11771a..6867eb9 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-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)
diff --git a/module/system/vm/assembler.scm b/module/system/vm/assembler.scm
index 8599aa0..5be16f6 100644
--- a/module/system/vm/assembler.scm
+++ b/module/system/vm/assembler.scm
@@ -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))