module/srfi/srfi-9.scm

   1 ;;; srfi-9.scm --- define-record-type
   2
   3 ;;      Copyright (C) 2001, 2002, 2006, 2009 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-inlinable
  68   ;; Define a macro and a procedure such that direct calls are inlined, via
  69   ;; the macro expansion, whereas references in non-call contexts refer to
  70   ;; the procedure.  Inspired by the `define-integrable' macro by Dybvig et al.
  71   (lambda (x)
  72     (define (make-procedure-name name)
  73       (datum->syntax name
  74                      (symbol-append '% (syntax->datum name)
  75                                     '-procedure)))
  76
  77     (syntax-case x ()
  78       ((_ (name formals ...) body ...)
  79        (identifier? #'name)
  80        (with-syntax ((proc-name (make-procedure-name #'name)))
  81          #`(begin
  82              (define (proc-name formals ...)
  83                body ...)
  84              proc-name ;; unused
  85              (define-syntax name
  86                (lambda (x)
  87                  (syntax-case x ()
  88                    ((_ formals ...)
  89                     #'(begin body ...))
  90                    (_
  91                     (identifier? x)
  92                     #'proc-name))))))))))
  93
  94 (define-syntax define-record-type
  95   (lambda (x)
  96     (define (field-identifiers field-specs)
  97       (syntax-case field-specs ()
  98         ((field-spec)
  99          (syntax-case #'field-spec ()
 100            ((name accessor) #'(name))
 101            ((name accessor modifier) #'(name))))
 102         ((field-spec rest ...)
 103          (append (field-identifiers #'(field-spec))
 104                  (field-identifiers #'(rest ...))))))
 105
 106     (define (field-indices fields)
 107       (fold (lambda (field result)
 108               (let ((i (if (null? result)
 109                            0
 110                            (+ 1 (cdar result)))))
 111                 (alist-cons field i result)))
 112             '()
 113             fields))
 114
 115     (define (constructor type-name constructor-spec indices)
 116       (syntax-case constructor-spec ()
 117         ((ctor field ...)
 118          (let ((field-count (length indices))
 119                (ctor-args   (map (lambda (field)
 120                                    (cons (syntax->datum field) field))
 121                                  #'(field ...))))
 122            #`(define #,constructor-spec
 123                (make-struct #,type-name 0
 124                             #,@(unfold
 125                                 (lambda (field-num)
 126                                   (>= field-num field-count))
 127                                 (lambda (field-num)
 128                                   (let* ((name
 129                                           (car (find (lambda (f+i)
 130                                                        (= (cdr f+i) field-num))
 131                                                      indices)))
 132                                          (arg (assq name ctor-args)))
 133                                     (if (pair? arg)
 134                                         (cdr arg)
 135                                         #'#f)))
 136                                 1+
 137                                 0)))))))
 138
 139     (define (accessors type-name field-specs indices)
 140       (syntax-case field-specs ()
 141         ((field-spec)
 142          (syntax-case #'field-spec ()
 143            ((name accessor)
 144             (with-syntax ((index (assoc-ref indices (syntax->datum #'name))))
 145               #`((define-inlinable (accessor s)
 146                    (if (eq? (struct-vtable s) #,type-name)
 147                        (struct-ref s index)
 148                        (throw 'wrong-type-arg 'accessor
 149                               "Wrong type argument: ~S" (list s)
 150                               (list s)))))))
 151            ((name accessor modifier)
 152             (with-syntax ((index (assoc-ref indices (syntax->datum #'name))))
 153               #`(#,@(accessors type-name #'((name accessor)) indices)
 154                  (define-inlinable (modifier s val)
 155                    (if (eq? (struct-vtable s) #,type-name)
 156                        (struct-set! s index val)
 157                        (throw 'wrong-type-arg 'modifier
 158                               "Wrong type argument: ~S" (list s)
 159                               (list s)))))))))
 160         ((field-spec rest ...)
 161          #`(#,@(accessors type-name #'(field-spec) indices)
 162             #,@(accessors type-name #'(rest ...) indices)))))
 163
 164     (syntax-case x ()
 165       ((_ type-name constructor-spec predicate-name field-spec ...)
 166        (let* ((fields      (field-identifiers #'(field-spec ...)))
 167               (field-count (length fields))
 168               (layout      (string-concatenate (make-list field-count "pw")))
 169               (indices     (field-indices (map syntax->datum fields))))
 170          #`(begin
 171              (define type-name
 172                (make-vtable #,layout
 173                             (lambda (obj port)
 174                               (format port "#<~A" 'type-name)
 175                               #,@(map (lambda (field)
 176                                         (let* ((f (syntax->datum field))
 177                                                (i (assoc-ref indices f)))
 178                                           #`(format port " ~A: ~S" '#,field
 179                                                     (struct-ref obj #,i))))
 180                                       fields)
 181                               (format port ">"))))
 182              (define-inlinable (predicate-name obj)
 183                (and (struct? obj)
 184                     (eq? (struct-vtable obj) type-name)))
 185
 186              #,(constructor #'type-name #'constructor-spec indices)
 187
 188              #,@(accessors #'type-name #'(field-spec ...) indices)))))))
 189
 190 ;;; srfi-9.scm ends here