module/srfi/srfi-9.scm

   1 ;;; srfi-9.scm --- define-record-type
   2
   3 ;;      Copyright (C) 2001, 2002, 2006, 2009, 2010, 2011 Free Software Foundation, Inc.
   4 ;;
   5 ;; This library is free software; you can redistribute it and/or
   6 ;; modify it under the terms of the GNU Lesser General Public
   7 ;; License as published by the Free Software Foundation; either
   8 ;; version 3 of the License, or (at your option) any later version.
   9 ;;
  10 ;; This library is distributed in the hope that it will be useful,
  11 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  12 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  13 ;; Lesser General Public License for more details.
  14 ;;
  15 ;; You should have received a copy of the GNU Lesser General Public
  16 ;; License along with this library; if not, write to the Free Software
  17 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  18
  19 ;;; Commentary:
  20
  21 ;; This module exports the syntactic form `define-record-type', which
  22 ;; is the means for creating record types defined in SRFI-9.
  23 ;;
  24 ;; The syntax of a record type definition is:
  25 ;;
  26 ;;  <record type definition>
  27 ;;    -> (define-record-type <type name>
  28 ;;         (<constructor name> <field tag> ...)
  29 ;;         <predicate name>
  30 ;;         <field spec> ...)
  31 ;;
  32 ;;  <field spec> -> (<field tag> <accessor name>)
  33 ;;               -> (<field tag> <accessor name> <modifier name>)
  34 ;;
  35 ;;  <field tag> -> <identifier>
  36 ;;  <... name>  -> <identifier>
  37 ;;
  38 ;; Usage example:
  39 ;;
  40 ;; guile> (use-modules (srfi srfi-9))
  41 ;; guile> (define-record-type :foo (make-foo x) foo?
  42 ;;                            (x get-x) (y get-y set-y!))
  43 ;; guile> (define f (make-foo 1))
  44 ;; guile> f
  45 ;; #<:foo x: 1 y: #f>
  46 ;; guile> (get-x f)
  47 ;; 1
  48 ;; guile> (set-y! f 2)
  49 ;; 2
  50 ;; guile> (get-y f)
  51 ;; 2
  52 ;; guile> f
  53 ;; #<:foo x: 1 y: 2>
  54 ;; guile> (foo? f)
  55 ;; #t
  56 ;; guile> (foo? 1)
  57 ;; #f
  58
  59 ;;; Code:
  60
  61 (define-module (srfi srfi-9)
  62   #:use-module (srfi srfi-1)
  63   #:export (define-record-type))
  64
  65 (cond-expand-provide (current-module) '(srfi-9))
  66
  67 (define-syntax define-record-type
  68   (lambda (x)
  69     (define (field-identifiers field-specs)
  70       (syntax-case field-specs ()
  71         (()
  72          '())
  73         ((field-spec)
  74          (syntax-case #'field-spec ()
  75            ((name accessor) #'(name))
  76            ((name accessor modifier) #'(name))))
  77         ((field-spec rest ...)
  78          (append (field-identifiers #'(field-spec))
  79                  (field-identifiers #'(rest ...))))))
  80
  81     (define (field-indices fields)
  82       (fold (lambda (field result)
  83               (let ((i (if (null? result)
  84                            0
  85                            (+ 1 (cdar result)))))
  86                 (alist-cons field i result)))
  87             '()
  88             fields))
  89
  90     (define (constructor type-name constructor-spec indices)
  91       (syntax-case constructor-spec ()
  92         ((ctor field ...)
  93          (let ((field-count (length indices))
  94                (ctor-args   (map (lambda (field)
  95                                    (cons (syntax->datum field) field))
  96                                  #'(field ...))))
  97            #`(define-inlinable #,constructor-spec
  98                (make-struct #,type-name 0
  99                             #,@(unfold
 100                                 (lambda (field-num)
 101                                   (>= field-num field-count))
 102                                 (lambda (field-num)
 103                                   (let* ((name
 104                                           (car (find (lambda (f+i)
 105                                                        (= (cdr f+i) field-num))
 106                                                      indices)))
 107                                          (arg (assq name ctor-args)))
 108                                     (if (pair? arg)
 109                                         (cdr arg)
 110                                         #'#f)))
 111                                 1+
 112                                 0)))))))
 113
 114     (define (accessors type-name field-specs indices)
 115       (syntax-case field-specs ()
 116         (()
 117          #'())
 118         ((field-spec)
 119          (syntax-case #'field-spec ()
 120            ((name accessor)
 121             (with-syntax ((index (assoc-ref indices (syntax->datum #'name))))
 122               #`((define-inlinable (accessor s)
 123                    (if (eq? (struct-vtable s) #,type-name)
 124                        (struct-ref s index)
 125                        (throw 'wrong-type-arg 'accessor
 126                               "Wrong type argument: ~S" (list s)
 127                               (list s)))))))
 128            ((name accessor modifier)
 129             (with-syntax ((index (assoc-ref indices (syntax->datum #'name))))
 130               #`(#,@(accessors type-name #'((name accessor)) indices)
 131                  (define-inlinable (modifier s val)
 132                    (if (eq? (struct-vtable s) #,type-name)
 133                        (struct-set! s index val)
 134                        (throw 'wrong-type-arg 'modifier
 135                               "Wrong type argument: ~S" (list s)
 136                               (list s)))))))))
 137         ((field-spec rest ...)
 138          #`(#,@(accessors type-name #'(field-spec) indices)
 139             #,@(accessors type-name #'(rest ...) indices)))))
 140
 141     (syntax-case x ()
 142       ((_ type-name constructor-spec predicate-name field-spec ...)
 143        (let* ((fields      (field-identifiers #'(field-spec ...)))
 144               (field-count (length fields))
 145               (layout      (string-concatenate (make-list field-count "pw")))
 146               (indices     (field-indices (map syntax->datum fields))))
 147          #`(begin
 148              (define type-name
 149                (make-vtable #,layout
 150                             (lambda (obj port)
 151                               (format port "#<~A" 'type-name)
 152                               #,@(map (lambda (field)
 153                                         (let* ((f (syntax->datum field))
 154                                                (i (assoc-ref indices f)))
 155                                           #`(format port " ~A: ~S" '#,field
 156                                                     (struct-ref obj #,i))))
 157                                       fields)
 158                               (format port ">"))))
 159              (define-inlinable (predicate-name obj)
 160                (and (struct? obj)
 161                     (eq? (struct-vtable obj) type-name)))
 162
 163              #,(constructor #'type-name #'constructor-spec indices)
 164
 165              #,@(accessors #'type-name #'(field-spec ...) indices)))))))
 166
 167 ;;; srfi-9.scm ends here