mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-29 19:30:36 +02:00
341 lines
13 KiB
Scheme
341 lines
13 KiB
Scheme
;;; srfi-9.scm --- define-record-type
|
|
|
|
;; Copyright (C) 2001-2002,2006,2008-2014,2018-2019,2023-2024
|
|
;; 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:
|
|
|
|
;; This module exports the syntactic form `define-record-type', which
|
|
;; is the means for creating record types defined in SRFI-9.
|
|
;;
|
|
;; The syntax of a record type definition is:
|
|
;;
|
|
;; <record type definition>
|
|
;; -> (define-record-type <type name>
|
|
;; (<constructor name> <field tag> ...)
|
|
;; <predicate name>
|
|
;; <field spec> ...)
|
|
;;
|
|
;; <field spec> -> (<field tag> <getter name>)
|
|
;; -> (<field tag> <getter name> <setter name>)
|
|
;;
|
|
;; <field tag> -> <identifier>
|
|
;; <... name> -> <identifier>
|
|
;;
|
|
;; Usage example:
|
|
;;
|
|
;; guile> (use-modules (srfi srfi-9))
|
|
;; guile> (define-record-type :foo (make-foo x) foo?
|
|
;; (x get-x) (y get-y set-y!))
|
|
;; guile> (define f (make-foo 1))
|
|
;; guile> f
|
|
;; #<:foo x: 1 y: #f>
|
|
;; guile> (get-x f)
|
|
;; 1
|
|
;; guile> (set-y! f 2)
|
|
;; 2
|
|
;; guile> (get-y f)
|
|
;; 2
|
|
;; guile> f
|
|
;; #<:foo x: 1 y: 2>
|
|
;; guile> (foo? f)
|
|
;; #t
|
|
;; guile> (foo? 1)
|
|
;; #f
|
|
|
|
;;; Code:
|
|
|
|
(define-module (srfi srfi-9)
|
|
#:use-module (srfi srfi-1)
|
|
#:use-module (system base ck)
|
|
#:export (define-record-type))
|
|
|
|
(cond-expand-provide (current-module) '(srfi-9))
|
|
|
|
;; Roll our own instead of using the public `define-inlinable'. This is
|
|
;; because the public one has a different `make-procedure-name', so
|
|
;; using it would require users to recompile code that uses SRFI-9. See
|
|
;; <http://lists.gnu.org/archive/html/guile-devel/2011-04/msg00111.html>.
|
|
;;
|
|
|
|
(define-syntax-rule (define-inlinable (name formals ...) body ...)
|
|
(define-tagged-inlinable () (name formals ...) body ...))
|
|
|
|
;; 'define-tagged-inlinable' has an additional feature: it stores a map
|
|
;; of keys to values that can be retrieved at expansion time. This is
|
|
;; currently used to retrieve the rtd id, field index, and record copier
|
|
;; macro for an arbitrary getter.
|
|
|
|
(define-syntax-rule (%%on-error err) err)
|
|
|
|
(define %%type #f) ; a private syntax literal
|
|
(define-syntax getter-type
|
|
(syntax-rules (quote)
|
|
((_ s 'getter 'err)
|
|
(getter (%%on-error err) %%type s))))
|
|
|
|
(define %%index #f) ; a private syntax literal
|
|
(define-syntax getter-index
|
|
(syntax-rules (quote)
|
|
((_ s 'getter 'err)
|
|
(getter (%%on-error err) %%index s))))
|
|
|
|
(define %%copier #f) ; a private syntax literal
|
|
(define-syntax getter-copier
|
|
(syntax-rules (quote)
|
|
((_ s 'getter 'err)
|
|
(getter (%%on-error err) %%copier s))))
|
|
|
|
(define-syntax define-tagged-inlinable
|
|
(lambda (x)
|
|
(define (make-procedure-name name)
|
|
(datum->syntax name
|
|
(symbol-append '% (syntax->datum name)
|
|
'-procedure)))
|
|
|
|
(syntax-case x ()
|
|
((_ ((key value) ...) (name formals ...) body0 body ...)
|
|
(identifier? #'name)
|
|
(with-syntax ((proc-name (make-procedure-name #'name))
|
|
((args ...) (generate-temporaries #'(formals ...))))
|
|
#`(begin
|
|
(define (proc-name formals ...)
|
|
#((maybe-unused))
|
|
body0 body ...)
|
|
(define-syntax name
|
|
(lambda (x)
|
|
(syntax-case x (%%on-error key ...)
|
|
((_ (%%on-error err) key s) #'(ck s 'value)) ...
|
|
((_ args ...)
|
|
#'((lambda (formals ...)
|
|
body0 body ...)
|
|
args ...))
|
|
((_ a (... ...))
|
|
(syntax-violation 'name "Wrong number of arguments" x))
|
|
(_
|
|
(identifier? x)
|
|
#'proc-name))))))))))
|
|
|
|
(define (default-record-printer s p)
|
|
(display "#<" p)
|
|
(display (record-type-name (record-type-descriptor s)) p)
|
|
(let loop ((fields (record-type-fields (record-type-descriptor s)))
|
|
(off 0))
|
|
(cond
|
|
((not (null? fields))
|
|
(display " " p)
|
|
(display (car fields) p)
|
|
(display ": " p)
|
|
(write (struct-ref s off) p)
|
|
(loop (cdr fields) (+ 1 off)))))
|
|
(display ">" p))
|
|
|
|
(define-syntax-rule (throw-bad-struct s who)
|
|
(let ((s* s))
|
|
(throw 'wrong-type-arg who
|
|
"Wrong type argument: ~S" (list s*)
|
|
(list s*))))
|
|
|
|
(define (make-copier-id type-name)
|
|
(datum->syntax type-name
|
|
(symbol-append '%% (syntax->datum type-name)
|
|
'-set-fields)))
|
|
|
|
(define-syntax %%set-fields
|
|
(lambda (x)
|
|
(syntax-case x ()
|
|
((_ type-name (getter-id ...) check? s (getter expr) ...)
|
|
(every identifier? #'(getter ...))
|
|
(let ((copier-name (syntax->datum (make-copier-id #'type-name)))
|
|
(getter+exprs #'((getter expr) ...))
|
|
(nfields (length #'(getter-id ...))))
|
|
(define (lookup id default-expr)
|
|
(let ((results
|
|
(filter (lambda (g+e)
|
|
(free-identifier=? id (car g+e)))
|
|
getter+exprs)))
|
|
(case (length results)
|
|
((0) default-expr)
|
|
((1) (cadar results))
|
|
(else (syntax-violation
|
|
copier-name "duplicate getter" x id)))))
|
|
(for-each (lambda (id)
|
|
(or (find (lambda (getter-id)
|
|
(free-identifier=? id getter-id))
|
|
#'(getter-id ...))
|
|
(syntax-violation
|
|
copier-name "unknown getter" x id)))
|
|
#'(getter ...))
|
|
(with-syntax ((unsafe-expr
|
|
#`(make-struct/simple
|
|
type-name
|
|
#,@(map (lambda (getter index)
|
|
(lookup getter #`(struct-ref s #,index)))
|
|
#'(getter-id ...)
|
|
(iota nfields)))))
|
|
(if (syntax->datum #'check?)
|
|
#`(if (eq? (struct-vtable s) type-name)
|
|
unsafe-expr
|
|
(throw-bad-struct
|
|
s '#,(datum->syntax #'here copier-name)))
|
|
#'unsafe-expr)))))))
|
|
|
|
(define-syntax %define-record-type
|
|
(lambda (x)
|
|
(define (field-identifiers field-specs)
|
|
(map (lambda (field-spec)
|
|
(syntax-case field-spec ()
|
|
((name getter) #'name)
|
|
((name getter setter) #'name)))
|
|
field-specs))
|
|
|
|
(define (getter-identifiers field-specs)
|
|
(map (lambda (field-spec)
|
|
(syntax-case field-spec ()
|
|
((name getter) #'getter)
|
|
((name getter setter) #'getter)))
|
|
field-specs))
|
|
|
|
(define (constructor form type-name constructor-spec field-ids)
|
|
(syntax-case constructor-spec ()
|
|
((ctor field ...)
|
|
(every identifier? #'(field ...))
|
|
(letrec* ((id-list-contains?
|
|
(lambda (id-list id)
|
|
(and (not (null? id-list))
|
|
(or (free-identifier=? (car id-list) id)
|
|
(id-list-contains? (cdr id-list) id)))))
|
|
(inits (map (lambda (id)
|
|
(and (id-list-contains? #'(field ...) id) id))
|
|
field-ids)))
|
|
(for-each
|
|
(lambda (field)
|
|
(unless (id-list-contains? field-ids field)
|
|
(syntax-violation
|
|
(syntax-case form () ((macro . args) (syntax->datum #'macro)))
|
|
"unknown field in constructor spec"
|
|
form field)))
|
|
#'(field ...))
|
|
#`(define-inlinable #,constructor-spec
|
|
(make-struct/simple #,type-name #,@inits))))))
|
|
|
|
(define (getters type-name getter-ids copier-id)
|
|
(map (lambda (getter index)
|
|
#`(define-tagged-inlinable
|
|
((%%type #,type-name)
|
|
(%%index #,index)
|
|
(%%copier #,copier-id))
|
|
(#,getter s)
|
|
(if (eq? (struct-vtable s) #,type-name)
|
|
(struct-ref s #,index)
|
|
(throw-bad-struct s '#,getter))))
|
|
getter-ids
|
|
(iota (length getter-ids))))
|
|
|
|
(define (copier type-name getter-ids copier-id)
|
|
#`(define-syntax-rule
|
|
(#,copier-id check? s (getter expr) (... ...))
|
|
(%%set-fields #,type-name #,getter-ids
|
|
check? s (getter expr) (... ...))))
|
|
|
|
(define (setters type-name field-specs)
|
|
(filter-map (lambda (field-spec index)
|
|
(syntax-case field-spec ()
|
|
((name getter) #f)
|
|
((name getter setter)
|
|
#`(define-inlinable (setter s val)
|
|
(if (eq? (struct-vtable s) #,type-name)
|
|
(struct-set! s #,index val)
|
|
(throw-bad-struct s 'setter))))))
|
|
field-specs
|
|
(iota (length field-specs))))
|
|
|
|
(define (functional-setters copier-id field-specs)
|
|
(filter-map (lambda (field-spec index)
|
|
(syntax-case field-spec ()
|
|
((name getter) #f)
|
|
((name getter setter)
|
|
#`(define-inlinable (setter s val)
|
|
(#,copier-id #t s (getter val))))))
|
|
field-specs
|
|
(iota (length field-specs))))
|
|
|
|
(syntax-case x ()
|
|
((_ immutable? form type-name constructor-spec predicate-name
|
|
field-spec ...)
|
|
(let ()
|
|
(define (syntax-error message subform)
|
|
(syntax-violation (syntax-case #'form ()
|
|
((macro . args) (syntax->datum #'macro)))
|
|
message #'form subform))
|
|
(and (boolean? (syntax->datum #'immutable?))
|
|
(or (identifier? #'type-name)
|
|
(syntax-error "expected type name" #'type-name))
|
|
(syntax-case #'constructor-spec ()
|
|
((ctor args ...)
|
|
(every identifier? #'(ctor args ...))
|
|
#t)
|
|
(_ (syntax-error "invalid constructor spec"
|
|
#'constructor-spec)))
|
|
(or (identifier? #'predicate-name)
|
|
(syntax-error "expected predicate name" #'predicate-name))
|
|
(every (lambda (spec)
|
|
(syntax-case spec ()
|
|
((field getter) #t)
|
|
((field getter setter) #t)
|
|
(_ (syntax-error "invalid field spec" spec))))
|
|
#'(field-spec ...))))
|
|
(let* ((field-ids (field-identifiers #'(field-spec ...)))
|
|
(getter-ids (getter-identifiers #'(field-spec ...)))
|
|
(field-count (length field-ids))
|
|
(immutable? (syntax->datum #'immutable?))
|
|
(ctor-name (syntax-case #'constructor-spec ()
|
|
((ctor args ...) #'ctor)))
|
|
(copier-id (make-copier-id #'type-name)))
|
|
#`(begin
|
|
#,(constructor #'form #'type-name #'constructor-spec field-ids)
|
|
|
|
(define type-name
|
|
(let ((rtd (make-record-type 'type-name
|
|
'#,field-ids
|
|
default-record-printer)))
|
|
;; Allow record-type-constructor to return our
|
|
;; constructor.
|
|
(struct-set! rtd (+ 2 vtable-offset-user) #,ctor-name)
|
|
rtd))
|
|
|
|
(define-inlinable (predicate-name obj)
|
|
(and (struct? obj)
|
|
(eq? (struct-vtable obj) type-name)))
|
|
|
|
#,@(getters #'type-name getter-ids copier-id)
|
|
#,(copier #'type-name getter-ids copier-id)
|
|
#,@(if immutable?
|
|
(functional-setters copier-id #'(field-spec ...))
|
|
(setters #'type-name #'(field-spec ...))))))
|
|
((_ immutable? form . rest)
|
|
(syntax-violation
|
|
(syntax-case #'form ()
|
|
((macro . args) (syntax->datum #'macro)))
|
|
"invalid record definition syntax"
|
|
#'form)))))
|
|
|
|
(define-syntax-rule (define-record-type name ctor pred fields ...)
|
|
(%define-record-type #f (define-record-type name ctor pred fields ...)
|
|
name ctor pred fields ...))
|
|
|
|
;;; srfi-9.scm ends here
|