diff --git a/libguile/syntax.c b/libguile/syntax.c index 2da4e395e..649e36449 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 16229f659..8a98c1db4 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 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))