summaryrefslogtreecommitdiff
path: root/module
diff options
context:
space:
mode:
Diffstat (limited to 'module')
-rw-r--r--module/ice-9/boot-9.scm1
-rw-r--r--module/ice-9/psyntax-pp.scm7
-rw-r--r--module/ice-9/psyntax.scm14
-rw-r--r--module/system/vm/assembler.scm21
4 files changed, 22 insertions, 21 deletions
diff --git a/module/ice-9/boot-9.scm b/module/ice-9/boot-9.scm
index 89595f3f7..67d84ae52 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 95758255a..3732d5ac1 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 b11771aa0..6867eb933 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 8599aa005..5be16f6a8 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))