summaryrefslogtreecommitdiff
path: root/module/ice-9/source-properties.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/ice-9/source-properties.scm')
-rw-r--r--module/ice-9/source-properties.scm108
1 files changed, 108 insertions, 0 deletions
diff --git a/module/ice-9/source-properties.scm b/module/ice-9/source-properties.scm
new file mode 100644
index 000000000..b8abc276e
--- /dev/null
+++ b/module/ice-9/source-properties.scm
@@ -0,0 +1,108 @@
+;;; 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)
+ (weak-key-hash-table-ref global-source-properties obj
+ #:default (lambda (k) '()))
+ '()))
+
+(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))
+ (weak-key-hash-table-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)))