mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 20:00:19 +02:00
* module/srfi/srfi-9/gnu.scm (set-record-type-printer!): Change the parameter name to `proc'. * doc/ref/api-compound.texi (SRFI-9 Records): Update accordingly.
168 lines
6.3 KiB
Scheme
168 lines
6.3 KiB
Scheme
;;; Extensions to SRFI-9
|
|
|
|
;; Copyright (C) 2010, 2012 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, write to the Free Software
|
|
;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
|
|
|
|
;;; Commentary:
|
|
|
|
;; Extensions to SRFI-9. Fully documented in the Guile Reference Manual.
|
|
|
|
;;; Code:
|
|
|
|
(define-module (srfi srfi-9 gnu)
|
|
#:use-module (srfi srfi-1)
|
|
#:use-module (system base ck)
|
|
#:export (set-record-type-printer!
|
|
define-immutable-record-type
|
|
set-field
|
|
set-fields))
|
|
|
|
(define (set-record-type-printer! type proc)
|
|
"Set PROC as the custom printer for TYPE."
|
|
(struct-set! type vtable-index-printer proc))
|
|
|
|
(define-syntax-rule (define-immutable-record-type name ctor pred fields ...)
|
|
((@@ (srfi srfi-9) %define-record-type)
|
|
#t (define-immutable-record-type name ctor pred fields ...)
|
|
name ctor pred fields ...))
|
|
|
|
(define-syntax-rule (set-field s (getter ...) expr)
|
|
(%set-fields #t (set-field s (getter ...) expr) ()
|
|
s ((getter ...) expr)))
|
|
|
|
(define-syntax-rule (set-fields s . rest)
|
|
(%set-fields #t (set-fields s . rest) ()
|
|
s . rest))
|
|
|
|
;;
|
|
;; collate-set-field-specs is a helper for %set-fields
|
|
;; thats combines all specs with the same head together.
|
|
;;
|
|
;; For example:
|
|
;;
|
|
;; SPECS: (((a b c) expr1)
|
|
;; ((a d) expr2)
|
|
;; ((b c) expr3)
|
|
;; ((c) expr4))
|
|
;;
|
|
;; RESULT: ((a ((b c) expr1)
|
|
;; ((d) expr2))
|
|
;; (b ((c) expr3))
|
|
;; (c (() expr4)))
|
|
;;
|
|
(define (collate-set-field-specs specs)
|
|
(define (insert head tail expr result)
|
|
(cond ((find (lambda (tree)
|
|
(free-identifier=? head (car tree)))
|
|
result)
|
|
=> (lambda (tree)
|
|
`((,head (,tail ,expr)
|
|
,@(cdr tree))
|
|
,@(delq tree result))))
|
|
(else `((,head (,tail ,expr))
|
|
,@result))))
|
|
(with-syntax (((((head . tail) expr) ...) specs))
|
|
(fold insert '() #'(head ...) #'(tail ...) #'(expr ...))))
|
|
|
|
(define-syntax unknown-getter
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
((_ orig-form getter)
|
|
(syntax-violation 'set-fields "unknown getter" #'orig-form #'getter)))))
|
|
|
|
(define-syntax c-list
|
|
(lambda (x)
|
|
(syntax-case x (quote)
|
|
((_ s 'v ...)
|
|
#'(ck s '(v ...))))))
|
|
|
|
(define-syntax c-same-type-check
|
|
(lambda (x)
|
|
(syntax-case x (quote)
|
|
((_ s 'orig-form '(path ...)
|
|
'(getter0 getter ...)
|
|
'(type0 type ...)
|
|
'on-success)
|
|
(every (lambda (t g)
|
|
(or (free-identifier=? t #'type0)
|
|
(syntax-violation
|
|
'set-fields
|
|
(format #f
|
|
"\
|
|
field paths ~a and ~a require one object to belong to two different record types (~a and ~a)"
|
|
(syntax->datum #`(path ... #,g))
|
|
(syntax->datum #'(path ... getter0))
|
|
(syntax->datum t)
|
|
(syntax->datum #'type0))
|
|
#'orig-form)))
|
|
#'(type ...)
|
|
#'(getter ...))
|
|
#'(ck s 'on-success)))))
|
|
|
|
(define-syntax %set-fields
|
|
(lambda (x)
|
|
(with-syntax ((getter-type #'(@@ (srfi srfi-9) getter-type))
|
|
(getter-index #'(@@ (srfi srfi-9) getter-index))
|
|
(getter-copier #'(@@ (srfi srfi-9) getter-copier)))
|
|
(syntax-case x ()
|
|
((_ check? orig-form (path-so-far ...)
|
|
s)
|
|
#'s)
|
|
((_ check? orig-form (path-so-far ...)
|
|
s (() e))
|
|
#'e)
|
|
((_ check? orig-form (path-so-far ...)
|
|
struct-expr ((head . tail) expr) ...)
|
|
(let ((collated-specs (collate-set-field-specs
|
|
#'(((head . tail) expr) ...))))
|
|
(with-syntax (((getter0 getter ...)
|
|
(map car collated-specs)))
|
|
(with-syntax ((err #'(unknown-getter
|
|
orig-form getter0)))
|
|
#`(ck
|
|
()
|
|
(c-same-type-check
|
|
'orig-form
|
|
'(path-so-far ...)
|
|
'(getter0 getter ...)
|
|
(c-list (getter-type 'getter0 'err)
|
|
(getter-type 'getter 'err) ...)
|
|
'(let ((s struct-expr))
|
|
((ck () (getter-copier 'getter0 'err))
|
|
check?
|
|
s
|
|
#,@(map (lambda (spec)
|
|
(with-syntax (((head (tail expr) ...) spec))
|
|
(with-syntax ((err #'(unknown-getter
|
|
orig-form head)))
|
|
#'(head (%set-fields
|
|
check?
|
|
orig-form
|
|
(path-so-far ... head)
|
|
(struct-ref s (ck () (getter-index
|
|
'head 'err)))
|
|
(tail expr) ...)))))
|
|
collated-specs)))))))))
|
|
((_ check? orig-form (path-so-far ...)
|
|
s (() e) (() e*) ...)
|
|
(syntax-violation 'set-fields "duplicate field path"
|
|
#'orig-form #'(path-so-far ...)))
|
|
((_ check? orig-form (path-so-far ...)
|
|
s ((getter ...) expr) ...)
|
|
(syntax-violation 'set-fields "one field path is a prefix of another"
|
|
#'orig-form #'(path-so-far ...)))
|
|
((_ check? orig-form . rest)
|
|
(syntax-violation 'set-fields "invalid syntax" #'orig-form))))))
|