mirror of
https://git.savannah.gnu.org/git/guile.git
synced 2025-04-30 20:00:19 +02:00
92fac8c056
* module/system/base/ck.scm: New module. * module/srfi/srfi-9.scm: Import (system base ck). (getter-type, getter-index, getter-copier): Convert incoming argument convention to CK form. (define-tagged-inlinable): Convert return value convention for key lookup to CK form. * module/srfi/srfi-9/gnu.scm: Import (system base ck). Rename '%set-fields-unknown-getter' to 'unknown-getter'. (c-list, c-same-type-check): New macros. (%set-fields): Using the CK abstract machine, arrange to check (at macro expansion time) that all of the getters in head position correspond to the same record type. * test-suite/tests/srfi-9.test: Add test.
341 lines
13 KiB
Scheme
341 lines
13 KiB
Scheme
;;; srfi-9.scm --- define-record-type
|
|
|
|
;; Copyright (C) 2001, 2002, 2006, 2009, 2010, 2011, 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:
|
|
|
|
;; 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 ...) body ...)
|
|
(identifier? #'name)
|
|
(with-syntax ((proc-name (make-procedure-name #'name))
|
|
((args ...) (generate-temporaries #'(formals ...))))
|
|
#`(begin
|
|
(define (proc-name formals ...)
|
|
body ...)
|
|
(define-syntax name
|
|
(lambda (x)
|
|
(syntax-case x (%%on-error key ...)
|
|
((_ (%%on-error err) key s) #'(ck s 'value)) ...
|
|
((_ args ...)
|
|
#'((lambda (formals ...)
|
|
body ...)
|
|
args ...))
|
|
(_
|
|
(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 (throw-bad-struct s who)
|
|
(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) ...)))
|
|
(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
|
|
type-name 0
|
|
#,@(map (lambda (getter index)
|
|
(lookup getter #`(struct-ref s #,index)))
|
|
#'(getter-id ...)
|
|
(iota (length #'(getter-id ...)))))))
|
|
(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-names)
|
|
(syntax-case constructor-spec ()
|
|
((ctor field ...)
|
|
(every identifier? #'(field ...))
|
|
(let ((ctor-args (map (lambda (field)
|
|
(let ((name (syntax->datum field)))
|
|
(or (memq name field-names)
|
|
(syntax-violation
|
|
(syntax-case form ()
|
|
((macro . args)
|
|
(syntax->datum #'macro)))
|
|
"unknown field in constructor spec"
|
|
form field))
|
|
(cons name field)))
|
|
#'(field ...))))
|
|
#`(define-inlinable #,constructor-spec
|
|
(make-struct #,type-name 0
|
|
#,@(map (lambda (name)
|
|
(assq-ref ctor-args name))
|
|
field-names)))))))
|
|
|
|
(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))))
|
|
|
|
(define (record-layout immutable? count)
|
|
(let ((desc (if immutable? "pr" "pw")))
|
|
(string-concatenate (make-list count desc))))
|
|
|
|
(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?))
|
|
(layout (record-layout immutable? field-count))
|
|
(field-names (map syntax->datum field-ids))
|
|
(ctor-name (syntax-case #'constructor-spec ()
|
|
((ctor args ...) #'ctor)))
|
|
(copier-id (make-copier-id #'type-name)))
|
|
#`(begin
|
|
#,(constructor #'form #'type-name #'constructor-spec field-names)
|
|
|
|
(define type-name
|
|
(let ((rtd (make-struct/no-tail
|
|
record-type-vtable
|
|
'#,(datum->syntax #'here (make-struct-layout layout))
|
|
default-record-printer
|
|
'type-name
|
|
'#,field-ids)))
|
|
(set-struct-vtable-name! rtd 'type-name)
|
|
(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
|