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.

diff --git a/libguile/syntax.c b/libguile/syntax.c
index 2da4e395e4364683bfd8cfe3ba98e9ed0f2aea86..649e364499017c174e09aefee95f29db4760df03 100644 (file)
--- 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 @@
 
 \f
 
+/* 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 16229f659338052c5ef83b4d33b82b43b3ed8aa1..8a98c1db4af99facbdd71798c4bcae19adab1992 100644 (file)
--- 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 89595f3f7731ac8581a0db7df4c296a4a122aff6..67d84ae52b12be813d7388a58aa64f8b2c69caeb 100644 (file)
--- 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 95758255a376f25995c1e29ed6ff2bcea1090896..3732d5ac16ad37f087a78fb1423aa4b574a8098f 100644 (file)
--- 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 b11771aa00d3d9ab4a9ded8f2a8a0f34a9d81ea8..6867eb933820c8fe45116340517e83c5181f3dff 100644 (file)
--- 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 8599aa0053798bbc816717474872c325173952eb..5be16f6a8cfab3e759a0bd8c2b50aba2a283bb50 100644 (file)
--- 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))