mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-07-02 07:40:30 +02:00
92408ac20e
* libguile/read.c (scm_t_read_context): Add 'datum_label_table' and 'datum_label_tag' members. (scm_datum_label_definition, scm_datum_label_reference) (datum_is_placeholder, resolve_placeholder) resolve_datum_labels, scm_resolve_datum_labels): New static functions. (scm_read_array): Handle datum labels. (scm_read): Call 'scm_resolve_datum_labels'. (init_read_context): Initialize 'datum_label_table', and 'datum_label_tag'. * module/srfi/srfi-38.scm (read-with-shared-structure): Make this an alias for Guile's core 'read'. Remove the old implementation.
149 lines
6 KiB
Scheme
149 lines
6 KiB
Scheme
;; Copyright (C) 2010, 2014 Free Software Foundation, Inc.
|
|
;; Copyright (C) Ray Dillinger 2003. All Rights Reserved.
|
|
;;
|
|
;; Contains code based upon Alex Shinn's public-domain implementation of
|
|
;; `read-with-shared-structure' found in Chicken's SRFI 38 egg.
|
|
|
|
;; Permission is hereby granted, free of charge, to any person obtaining
|
|
;; a copy of this software and associated documentation files (the
|
|
;; "Software"), to deal in the Software without restriction, including
|
|
;; without limitation the rights to use, copy, modify, merge, publish,
|
|
;; distribute, sublicense, and/or sell copies of the Software, and to
|
|
;; permit persons to whom the Software is furnished to do so, subject to
|
|
;; the following conditions:
|
|
|
|
;; The above copyright notice and this permission notice shall be
|
|
;; included in all copies or substantial portions of the Software.
|
|
|
|
;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
|
|
;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
|
|
;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
|
|
;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS
|
|
;; BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN
|
|
;; ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN
|
|
;; CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
|
|
;; SOFTWARE.
|
|
|
|
(define-module (srfi srfi-38)
|
|
#:export (write-with-shared-structure
|
|
read-with-shared-structure)
|
|
#:use-module (rnrs bytevectors)
|
|
#:use-module (srfi srfi-8)
|
|
#:use-module (srfi srfi-69)
|
|
#:use-module (system vm trap-state))
|
|
|
|
(cond-expand-provide (current-module) '(srfi-38))
|
|
|
|
;; Guile's built-in reader supports SRFI-38.
|
|
(define read-with-shared-structure read)
|
|
|
|
;; A printer that shows all sharing of substructures. Uses the Common
|
|
;; Lisp print-circle notation: #n# refers to a previous substructure
|
|
;; labeled with #n=. Takes O(n^2) time.
|
|
|
|
;; Code attributed to Al Petrofsky, modified by Ray Dillinger.
|
|
|
|
;; Modified in 2010 by Andreas Rottmann to use SRFI 69 hashtables,
|
|
;; making the time O(n), and adding some of Guile's data types to the
|
|
;; `interesting' objects.
|
|
|
|
(define* (write-with-shared-structure obj
|
|
#:optional
|
|
(outport (current-output-port))
|
|
(optarg #f))
|
|
|
|
;; We only track duplicates of pairs, vectors, strings, bytevectors,
|
|
;; structs (which subsume R6RS and SRFI-9 records), ports and (native)
|
|
;; hash-tables. We ignore zero-length vectors and strings because
|
|
;; r5rs doesn't guarantee that eq? treats them sanely (and they aren't
|
|
;; very interesting anyway).
|
|
|
|
(define (interesting? obj)
|
|
(or (pair? obj)
|
|
(and (vector? obj) (not (zero? (vector-length obj))))
|
|
(and (string? obj) (not (zero? (string-length obj))))
|
|
(bytevector? obj)
|
|
(struct? obj)
|
|
(port? obj)
|
|
(hash-table? obj)))
|
|
|
|
;; (write-obj OBJ STATE):
|
|
;;
|
|
;; STATE is a hashtable which has an entry for each interesting part
|
|
;; of OBJ. The associated value will be:
|
|
;;
|
|
;; -- a number if the part has been given one,
|
|
;; -- #t if the part will need to be assigned a number but has not been yet,
|
|
;; -- #f if the part will not need a number.
|
|
;; The entry `counter' in STATE should be the most recently
|
|
;; assigned number.
|
|
;;
|
|
;; Mutates STATE for any parts that had numbers assigned.
|
|
(define (write-obj obj state)
|
|
(define (write-interesting)
|
|
(cond ((pair? obj)
|
|
(display "(" outport)
|
|
(write-obj (car obj) state)
|
|
(let write-cdr ((obj (cdr obj)))
|
|
(cond ((and (pair? obj) (not (hash-table-ref state obj)))
|
|
(display " " outport)
|
|
(write-obj (car obj) state)
|
|
(write-cdr (cdr obj)))
|
|
((null? obj)
|
|
(display ")" outport))
|
|
(else
|
|
(display " . " outport)
|
|
(write-obj obj state)
|
|
(display ")" outport)))))
|
|
((vector? obj)
|
|
(display "#(" outport)
|
|
(let ((len (vector-length obj)))
|
|
(write-obj (vector-ref obj 0) state)
|
|
(let write-vec ((i 1))
|
|
(cond ((= i len) (display ")" outport))
|
|
(else (display " " outport)
|
|
(write-obj (vector-ref obj i) state)
|
|
(write-vec (+ i 1)))))))
|
|
;; else it's a string
|
|
(else (write obj outport))))
|
|
(cond ((interesting? obj)
|
|
(let ((val (hash-table-ref state obj)))
|
|
(cond ((not val) (write-interesting))
|
|
((number? val)
|
|
(begin (display "#" outport)
|
|
(write val outport)
|
|
(display "#" outport)))
|
|
(else
|
|
(let ((n (+ 1 (hash-table-ref state 'counter))))
|
|
(display "#" outport)
|
|
(write n outport)
|
|
(display "=" outport)
|
|
(hash-table-set! state 'counter n)
|
|
(hash-table-set! state obj n)
|
|
(write-interesting))))))
|
|
(else
|
|
(write obj outport))))
|
|
|
|
;; Scan computes the initial value of the hash table, which maps each
|
|
;; interesting part of the object to #t if it occurs multiple times,
|
|
;; #f if only once.
|
|
(define (scan obj state)
|
|
(cond ((not (interesting? obj)))
|
|
((hash-table-exists? state obj)
|
|
(hash-table-set! state obj #t))
|
|
(else
|
|
(hash-table-set! state obj #f)
|
|
(cond ((pair? obj)
|
|
(scan (car obj) state)
|
|
(scan (cdr obj) state))
|
|
((vector? obj)
|
|
(let ((len (vector-length obj)))
|
|
(do ((i 0 (+ 1 i)))
|
|
((= i len))
|
|
(scan (vector-ref obj i) state))))))))
|
|
|
|
(let ((state (make-hash-table eq?)))
|
|
(scan obj state)
|
|
(hash-table-set! state 'counter 0)
|
|
(write-obj obj state)))
|
|
|