mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-06-06 20:20:20 +02:00
8280c8485f
* libguile/weak-table.c: * libguile/weak-table.h: Remove. * libguile.h: Remove weak-table.h include. * libguile/Makefile.am (libguile_@GUILE_EFFECTIVE_VERSION@_la_SOURCES): (DOT_X_FILES): (DOT_DOC_FILES): (modinclude_HEADERS): Remove weak-table.[ch]. * libguile/evalext.c: * libguile/fluids.c: * libguile/hash.c: * libguile/init.c: * libguile/print.c: * libguile/scm.h: Remove uses of weak-table.h and free up the tc7. * libguile/hashtab.c: * libguile/hashtab.h: Add deprecated shims to dispatch to (ice-9 weak-tables) when working on weak tables. * module/ice-9/weak-tables.scm: New implementation. Embeds the hash and equality functions in the table itself. * module/ice-9/object-properties.scm: * module/ice-9/poe.scm: * module/ice-9/popen.scm: * module/ice-9/source-properties.scm: * module/language/cps/compile-bytecode.scm: * module/language/ecmascript/array.scm: * module/language/ecmascript/function.scm: * module/oop/goops/save.scm: * module/srfi/srfi-18.scm: * module/srfi/srfi-69.scm: * module/system/base/types.scm: * module/system/base/types/internal.scm: * module/system/foreign.scm: * module/system/vm/assembler.scm: * test-suite/tests/gc.test: * test-suite/tests/hash.test: * test-suite/tests/srfi-69.test: * test-suite/tests/types.test: * test-suite/tests/weaks.test: Update to use new, non-deprecated weak tables API.
108 lines
3.5 KiB
Scheme
108 lines
3.5 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)
|
||
(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)))
|