mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-06-17 17:20:29 +02:00
Code Activity

Add implementation of SRFI 38

Browse source 
* module/srfi/srfi-38.scm: New file, partly based on the reference
  implementation and on Alex Shinn's public-domain implementation for
  Chicken.
* module/Makefile.am (SRFI_SOURCES): Add srfi/srfi-38.scm.

* test-suite/tests/srfi-38.test: New file, minimal test suite for SRFI
  38.
* test-suite/Makefile.am (SCM_TESTS): Added tests/srfi-38.test.

* doc/ref/srfi-modules.texi: Add a node for SRFI 38.

Signed-off-by: Ludovic Courtès <ludo@gnu.org>
This commit is contained in:
Andreas Rottmann 2010-11-03 00:19:54 +01:00 • committed by Ludovic Courtès
parent d458073bc0
commit 12708eeb11
5 changed files with 400 additions and 1 deletions
Download patch file Download diff file Expand all files Collapse all files

125
doc/ref/srfi-modules.texi
View file

@ -42,6 +42,7 @@ get the relevant SRFI documents from the SRFI home page
* SRFI-34:: Exception handling.
* SRFI-35:: Conditions.
* SRFI-37:: args-fold program argument processor
* SRFI-38:: External Representation for Data With Shared Structure
* SRFI-39:: Parameter objects
* SRFI-42:: Eager comprehensions
* SRFI-45:: Primitives for expressing iterative lazy algorithms
@ -3619,7 +3620,6 @@ the user.
Return true if @var{c} is of type @code{&error} or one of its subtypes.
@end deffn
@node SRFI-37
@subsection SRFI-37 - args-fold
@cindex SRFI-37
@ -3706,6 +3706,129 @@ not named options. This includes arguments after @samp{--}. It is
called with the argument in question, as well as the seeds.
@end deffn
@node SRFI-38
@subsection SRFI-38 - External Representation for Data With Shared Structure
@cindex SRFI-38
This subsection is based on
@uref{http://srfi.schemers.org/srfi-38/srfi-38.html, the specification
of SRFI-38} written by Ray Dillinger.
@c Copyright (C) Ray Dillinger 2003. All Rights Reserved.
@c Permission is hereby granted, free of charge, to any person obtaining a
@c copy of this software and associated documentation files (the
@c "Software"), to deal in the Software without restriction, including
@c without limitation the rights to use, copy, modify, merge, publish,
@c distribute, sublicense, and/or sell copies of the Software, and to
@c permit persons to whom the Software is furnished to do so, subject to
@c the following conditions:
@c The above copyright notice and this permission notice shall be included
@c in all copies or substantial portions of the Software.
@c THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS
@c OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
@c MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
@c NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
@c LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
@c OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
@c WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
This SRFI creates an alternative external representation for data
written and read using @code{write-with-shared-structure} and
@code{read-with-shared-structure}. It is identical to the grammar for
external representation for data written and read with @code{write} and
@code{read} given in section 7 of R5RS, except that the single
production
@example
<datum> --> <simple datum> | <compound datum>
@end example
is replaced by the following five productions:
@example
<datum> --> <defining datum> | <nondefining datum> | <defined datum>
<defining datum> --> #<indexnum>=<nondefining datum>
<defined datum> --> #<indexnum>#
<nondefining datum> --> <simple datum> | <compound datum>
<indexnum> --> <digit 10>+
@end example
@deffn {Scheme procedure} write-with-shared-structure obj
@deffnx {Scheme procedure} write-with-shared-structure obj port
@deffnx {Scheme procedure} write-with-shared-structure obj port optarg
Writes an external representation of @var{obj} to the given port.
Strings that appear in the written representation are enclosed in
doublequotes, and within those strings backslash and doublequote
characters are escaped by backslashes. Character objects are written
using the @code{#\} notation.
Objects which denote locations rather than values (cons cells, vectors,
and non-zero-length strings in R5RS scheme; also Guile's structs,
bytevectors and ports and hash-tables), if they appear at more than one
point in the data being written, are preceded by @samp{#@var{N}=} the
first time they are written and replaced by @samp{#@var{N}#} all
subsequent times they are written, where @var{N} is a natural number
used to identify that particular object. If objects which denote
locations occur only once in the structure, then
@code{write-with-shared-structure} must produce the same external
representation for those objects as @code{write}.
@code{write-with-shared-structure} terminates in finite time and
produces a finite representation when writing finite data.
@code{write-with-shared-structure} returns an unspecified value. The
@var{port} argument may be omitted, in which case it defaults to the
value returned by @code{(current-output-port)}. The @var{optarg}
argument may also be omitted. If present, its effects on the output and
return value are unspecified but @code{write-with-shared-structure} must
still write a representation that can be read by
@code{read-with-shared-structure}. Some implementations may wish to use
@var{optarg} to specify formatting conventions, numeric radixes, or
return values. Guile's implementation ignores @var{optarg}.
For example, the code
@lisp
(begin (define a (cons 'val1 'val2))
(set-cdr! a a)
(write-with-shared-structure a))
@end lisp
should produce the output @code{#1=(val1 . #1#)}. This shows a cons
cell whose @code{cdr} contains itself.
@end deffn
@deffn {Scheme procedure} read-with-shared-structure
@deffnx {Scheme procedure} read-with-shared-structure port
@code{read-with-shared-structure} converts the external representations
of Scheme objects produced by @code{write-with-shared-structure} into
Scheme objects. That is, it is a parser for the nonterminal
@samp{<datum>} in the augmented external representation grammar defined
above. @code{read-with-shared-structure} returns the next object
parsable from the given input port, updating @var{port} to point to the
first character past the end of the external representation of the
object.
If an end-of-file is encountered in the input before any characters are
found that can begin an object, then an end-of-file object is returned.
The port remains open, and further attempts to read it (by
@code{read-with-shared-structure} or @code{read} will also return an
end-of-file object. If an end of file is encountered after the
beginning of an object's external representation, but the external
representation is incomplete and therefore not parsable, an error is
signalled.
The @var{port} argument may be omitted, in which case it defaults to the
value returned by @code{(current-input-port)}. It is an error to read
from a closed port.
@end deffn
@node SRFI-39
@subsection SRFI-39 - Parameters

1
module/Makefile.am
View file

@ -254,6 +254,7 @@ SRFI_SOURCES = \
srfi/srfi-34.scm \
srfi/srfi-35.scm \
srfi/srfi-37.scm \
srfi/srfi-38.scm \
srfi/srfi-42.scm \
srfi/srfi-39.scm \
srfi/srfi-45.scm \

206
module/srfi/srfi-38.scm Normal file
View file

@ -0,0 +1,206 @@
;; Copyright (C) 2010 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))
;; 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)))
;; A reader that understands the output of the above writer. This has
;; been written by Andreas Rottmann to re-use Guile's built-in reader,
;; with inspiration from Alex Shinn's public-domain implementation of
;; `read-with-shared-structure' found in Chicken's SRFI 38 egg.
(define* (read-with-shared-structure #:optional (port (current-input-port)))
(let ((parts-table (make-hash-table eqv?)))
;; reads chars that match PRED and returns them as a string.
(define (read-some-chars pred initial)
(let iter ((chars initial))
(let ((c (peek-char port)))
(if (or (eof-object? c) (not (pred c)))
(list->string (reverse chars))
(iter (cons (read-char port) chars))))))
(define (read-hash c port)
(let* ((n (string->number (read-some-chars char-numeric? (list c))))
(c (read-char port))
(thunk (hash-table-ref/default parts-table n #f)))
(case c
((#\=)
(if thunk
(error "Double declaration of part " n))
(let* ((cell (list #f))
(thunk (lambda () (car cell))))
(hash-table-set! parts-table n thunk)
(let ((obj (read port)))
(set-car! cell obj)
obj)))
((#\#)
(or thunk
(error "Use of undeclared part " n)))
(else
(error "Malformed shared part specifier")))))
(with-fluid* %read-hash-procedures (fluid-ref %read-hash-procedures)
(lambda ()
(for-each (lambda (digit)
(read-hash-extend digit read-hash))
'(#\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9))
(let ((result (read port)))
(if (< 0 (hash-table-size parts-table))
(patch! result))
result)))))
(define (hole? x) (procedure? x))
(define (fill-hole x) (if (hole? x) (fill-hole (x)) x))
(define (patch! x)
(cond
((pair? x)
(if (hole? (car x)) (set-car! x (fill-hole (car x))) (patch! (car x)))
(if (hole? (cdr x)) (set-cdr! x (fill-hole (cdr x))) (patch! (cdr x))))
((vector? x)
(do ((i (- (vector-length x) 1) (- i 1)))
((< i 0))
(let ((elt (vector-ref x i)))
(if (hole? elt)
(vector-set! x i (fill-hole elt))
(patch! elt)))))))

1
test-suite/Makefile.am
View file

@ -118,6 +118,7 @@ SCM_TESTS = tests/00-initial-env.test \
tests/srfi-34.test \
tests/srfi-35.test \
tests/srfi-37.test \
tests/srfi-38.test \
tests/srfi-39.test \
tests/srfi-42.test \
tests/srfi-45.test \

68
test-suite/tests/srfi-38.test Normal file
View file

@ -0,0 +1,68 @@
;;; srfi-38.test --- Tests for SRFI 38. -*- mode: scheme; -*-
;; Copyright (C) 2010 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 library. If not, see
;; <http://www.gnu.org/licenses/>.
;;; Code:
(define-module (test-srfi-38)
#:use-module (test-suite lib)
#:use-module (srfi srfi-38)
#:use-module (rnrs bytevectors))
(define (shared-structure->string object)
(call-with-output-string
(lambda (port)
(write-with-shared-structure object port))))
(define (roundtrip object)
(call-with-input-string (shared-structure->string object)
(lambda (port)
(read-with-shared-structure port))))
(with-test-prefix "pairs"
(let ((foo (cons 'value-1 #f)))
(set-cdr! foo foo)
(pass-if "writing"
(string=? "#1=(value-1 . #1#)"
(shared-structure->string foo)))
(pass-if "roundtrip"
(let ((result (roundtrip foo)))
(and (pair? result)
(eq? (car result) 'value-1)
(eq? (cdr result) result))))))
(with-test-prefix "bytevectors"
(let ((vec (vector 0 1 2 3))
(bv (u8-list->bytevector '(42 42))))
(vector-set! vec 0 bv)
(vector-set! vec 2 bv)
(pass-if "roundtrip"
(let ((result (roundtrip vec)))
(and (equal? '#(#vu8(42 42) 1 #vu8(42 42) 3)
result)
(eq? (vector-ref result 0)
(vector-ref result 2)))))))
(with-test-prefix "mixed"
(let* ((pair (cons 'a 'b))
(vec (vector 0 pair 2 pair #f)))
(vector-set! vec 4 vec)
(pass-if "roundtrip"
(let ((result (roundtrip vec)))
(and (eq? (vector-ref result 1)
(vector-ref result 3))
(eq? result (vector-ref result 4)))))))