mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-08 05:00:17 +02:00
e3b743dc72
* module/ice-9/source-properties.scm: New file, providing the source-properties API, as well as a replacement for `read' that always attaches source properties, regardless of the 'positions option on the port. * am/bootstrap.am (SOURCES): Add the new file. * libguile/srcprop.c: * libguile/srcprop.h: Remove. * libguile/Makefile.am (libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES): (DOT_X_FILES): (DOT_DOC_FILES): (modinclude_HEADERS): * libguile.h: Remove srcprop.h. * libguile/deprecated.c: * libguile/deprecated.h: Add deprecation shims for srcprop.h interface. * libguile/backtrace.c: * libguile/debug.c: * libguile/eval.c: * libguile/init.c: * libguile/memoize.c: * libguile/promises.c: * libguile/read.c: * libguile/syntax.c: Remove needless srcprop.h includes. * module/ice-9/boot-9.scm: Reorder some definitions so that deprecated modules can use the (system syntax internal) module. * module/ice-9/deprecated.scm: Add shims for Scheme source-properties interface. * module/ice-9/read.scm (read): Never attach source properties. Users that want source can use read-syntax. * module/language/cps.scm: * module/language/cps/spec.scm: * module/language/ecmascript/compile-tree-il.scm: * module/language/elisp/compile-tree-il.scm: * module/language/elisp/lexer.scm: * module/language/elisp/parser.scm: * module/language/tree-il.scm: * module/language/tree-il/spec.scm: * module/language/wisp.scm: * module/system/base/lalr.scm: * test-suite/tests/elisp-reader.test: * test-suite/tests/reader.test: * test-suite/tests/srcprop.test: * test-suite/tests/srfi-105.test: * test-suite/tests/srfi-119.test: Use the (ice-9 source-properties) module to get access to source properties.
107 lines
3.4 KiB
Scheme
107 lines
3.4 KiB
Scheme
;;; Copyright (C) 2025 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 License as
|
||
;;; published by the Free Software Foundation, either version 3 of the
|
||
;;; License, or (at your option) any later version.
|
||
;;;
|
||
;;; This library is distributed in the hope that it will be useful, but
|
||
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
|
||
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU
|
||
;;; Lesser General Public License for more details.
|
||
;;;
|
||
;;; You should have received a copy of the GNU Lesser General Public
|
||
;;; License along with this program. If not, see
|
||
;;; <http://www.gnu.org/licenses/>.
|
||
|
||
;;; Commentary:
|
||
;;;
|
||
;;; Code:
|
||
|
||
|
||
(define-module (ice-9 source-properties)
|
||
#:use-module (ice-9 weak-tables)
|
||
#:use-module (system syntax internal)
|
||
#:use-module (ice-9 match)
|
||
;; FIXME: Change to #:export when deprecated bindings removed.
|
||
#:replace (supports-source-properties?
|
||
source-property
|
||
set-source-property!
|
||
source-properties
|
||
set-source-properties!
|
||
read))
|
||
|
||
(define global-source-properties (make-weak-key-hash-table))
|
||
|
||
(define (immediate? x)
|
||
(cond
|
||
((exact-integer? x) (<= most-negative-fixnum x most-positive-fixnum))
|
||
((char? x) #t)
|
||
((eq? x #f) #t)
|
||
((eq? x #nil) #t)
|
||
((eq? x '()) #t)
|
||
((eq? x #t) #t)
|
||
((unspecified? x) #t)
|
||
((eof-object? x) #t)
|
||
(else #f)))
|
||
|
||
(define (supports-source-properties? x)
|
||
(cond
|
||
((immediate? x) #f)
|
||
((symbol? x) #f)
|
||
((keyword? x) #f)
|
||
(else #t)))
|
||
|
||
(define (source-properties obj)
|
||
(if (supports-source-properties? obj)
|
||
(hashq-ref global-source-properties obj '())
|
||
'()))
|
||
|
||
(define (set-source-properties! obj props)
|
||
(unless (supports-source-properties? obj)
|
||
(scm-error 'wrong-type-arg "set-source-properties!"
|
||
"Unexpected immediate value: ~S"
|
||
(list obj) #f))
|
||
(hashq-set! global-source-properties obj props))
|
||
|
||
(define (source-property obj key)
|
||
(and (supports-source-properties? obj)
|
||
(assq-ref (source-properties obj) key)))
|
||
|
||
(define (set-source-property! obj key value)
|
||
(unless (supports-source-properties? obj)
|
||
(scm-error 'wrong-type-arg "set-source-properties!"
|
||
"Unexpected immediate value: ~S"
|
||
(list obj) #f))
|
||
(set-source-properties! obj (assq-set! (source-properties obj) key value)))
|
||
|
||
(define (cons-source orig x y)
|
||
(let ((pair (cons x y))
|
||
(src (source-properties orig)))
|
||
(when (pair? src)
|
||
(set-source-properties! pair src))
|
||
pair))
|
||
|
||
(define* (read #:optional (port (current-input-port)))
|
||
(define (annotate x src)
|
||
(when (supports-source-properties? x)
|
||
(match src
|
||
(#(filename line column)
|
||
(set-source-properties! x `((filename . ,filename)
|
||
(line . ,line)
|
||
(column . ,column))))
|
||
(#f (values))))
|
||
x)
|
||
(define (strip-and-annotate x)
|
||
(cond
|
||
((syntax? x)
|
||
(annotate (strip-and-annotate (syntax-expression x))
|
||
(syntax-source x)))
|
||
((pair? x)
|
||
(cons (strip-and-annotate (car x))
|
||
(strip-and-annotate (cdr x))))
|
||
((vector? x)
|
||
(list->vector (map strip-and-annotate (vector->list x))))
|
||
(else
|
||
x)))
|
||
(strip-and-annotate (read-syntax port)))
|