diff options
Diffstat (limited to 'module/srfi/srfi-9.scm')
-rw-r--r-- | module/srfi/srfi-9.scm | 348 |
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 |