diff options
Diffstat (limited to 'module/ice-9/source-properties.scm')
-rw-r--r-- | module/ice-9/source-properties.scm | 108 |
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))) |