summaryrefslogtreecommitdiff
path: root/module/srfi/srfi-9.scm
diff options
context:
space:
mode:
Diffstat (limited to 'module/srfi/srfi-9.scm')
-rw-r--r--module/srfi/srfi-9.scm348
1 files changed, 348 insertions, 0 deletions
diff --git a/module/srfi/srfi-9.scm b/module/srfi/srfi-9.scm
new file mode 100644
index 000000000..aee8be01c
--- /dev/null
+++ b/module/srfi/srfi-9.scm
@@ -0,0 +1,348 @@
+;;; srfi-9.scm --- define-record-type
+
+;; Copyright (C) 2001, 2002, 2006, 2009, 2010, 2011, 2012,
+;; 2013, 2014, 2018 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 ...))
+ ((_ 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))))
+
+ (define (record-layout immutable? count)
+ ;; Mutability is expressed on the record level; all structs in the
+ ;; future will be mutable.
+ (string-concatenate (make-list count "pw")))
+
+ (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))
+ (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-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