* 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
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
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
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 \
--- /dev/null
+;; 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)))))))
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 \
--- /dev/null
+;;; 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)))))))
HCoop / bpt / guile.git / commitdiff