;;; 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 ;;; . ;;; 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)))