mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 20:00:19 +02:00
f31a076232
* module/srfi/srfi-9.scm (%define-record-type): Accept additional 'form' parameter which contains the original form of 'define-record-type' or 'define-immutable-record-type'. Add elaborate pattern guard which raises descriptive syntax errors for specific errors, and a fallback pattern to catch anything else. (define-record-type): Pass 'form' parameter to %define-record-type. * module/srfi/srfi-9/gnu.scm (define-immutable-record-type): Pass 'form' parameter to %define-record-type. * test-suite/tests/srfi-9.test: Add tests.
128 lines
4.9 KiB
Scheme
128 lines
4.9 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)
|
|
#:export (set-record-type-printer!
|
|
define-immutable-record-type
|
|
set-field
|
|
set-fields))
|
|
|
|
(define (set-record-type-printer! type thunk)
|
|
"Set a custom printer THUNK for TYPE."
|
|
(struct-set! type vtable-index-printer thunk))
|
|
|
|
(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 (getter ...) s expr)
|
|
(%set-fields #t (set-field (getter ...) s 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 %set-fields-unknown-getter
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
((_ orig-form getter)
|
|
(syntax-violation 'set-fields "unknown getter" #'orig-form #'getter)))))
|
|
|
|
(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 ((getter (caar collated-specs)))
|
|
(with-syntax ((err #'(%set-fields-unknown-getter
|
|
orig-form getter)))
|
|
#`(let ((s struct-expr))
|
|
((getter-copier getter err)
|
|
check?
|
|
s
|
|
#,@(map (lambda (spec)
|
|
(with-syntax (((head (tail expr) ...) spec))
|
|
(with-syntax ((err #'(%set-fields-unknown-getter
|
|
orig-form head)))
|
|
#'(head (%set-fields
|
|
check?
|
|
orig-form
|
|
(path-so-far ... head)
|
|
(struct-ref s (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))))))
|