module/srfi/srfi-9.scm

   1 ;;; srfi-9.scm --- define-record-type
   2
   3 ;; Copyright (C) 2001, 2002, 2006, 2009, 2010, 2011, 2012,
   4 ;;   2013 Free Software Foundation, Inc.
   5 ;;
   6 ;; This library is free software; you can redistribute it and/or
   7 ;; modify it under the terms of the GNU Lesser General Public
   8 ;; License as published by the Free Software Foundation; either
   9 ;; version 3 of the License, or (at your option) any later version.
  10 ;;
  11 ;; This library is distributed in the hope that it will be useful,
  12 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  13 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  14 ;; Lesser General Public License for more details.
  15 ;;
  16 ;; You should have received a copy of the GNU Lesser General Public
  17 ;; License along with this library; if not, write to the Free Software
  18 ;; Foundation, Inc., 51 Franklin Street, Fifth Floor, Boston, MA 02110-1301 USA
  19
  20 ;;; Commentary:
  21
  22 ;; This module exports the syntactic form `define-record-type', which
  23 ;; is the means for creating record types defined in SRFI-9.
  24 ;;
  25 ;; The syntax of a record type definition is:
  26 ;;
  27 ;;  <record type definition>
  28 ;;    -> (define-record-type <type name>
  29 ;;         (<constructor name> <field tag> ...)
  30 ;;         <predicate name>
  31 ;;         <field spec> ...)
  32 ;;
  33 ;;  <field spec> -> (<field tag> <getter name>)
  34 ;;               -> (<field tag> <getter name> <setter name>)
  35 ;;
  36 ;;  <field tag> -> <identifier>
  37 ;;  <... name>  -> <identifier>
  38 ;;
  39 ;; Usage example:
  40 ;;
  41 ;; guile> (use-modules (srfi srfi-9))
  42 ;; guile> (define-record-type :foo (make-foo x) foo?
  43 ;;                            (x get-x) (y get-y set-y!))
  44 ;; guile> (define f (make-foo 1))
  45 ;; guile> f
  46 ;; #<:foo x: 1 y: #f>
  47 ;; guile> (get-x f)
  48 ;; 1
  49 ;; guile> (set-y! f 2)
  50 ;; 2
  51 ;; guile> (get-y f)
  52 ;; 2
  53 ;; guile> f
  54 ;; #<:foo x: 1 y: 2>
  55 ;; guile> (foo? f)
  56 ;; #t
  57 ;; guile> (foo? 1)
  58 ;; #f
  59
  60 ;;; Code:
  61
  62 (define-module (srfi srfi-9)
  63   #:use-module (srfi srfi-1)
  64   #:use-module (system base ck)
  65   #:export (define-record-type))
  66
  67 (cond-expand-provide (current-module) '(srfi-9))
  68
  69 ;; Roll our own instead of using the public `define-inlinable'.  This is
  70 ;; because the public one has a different `make-procedure-name', so
  71 ;; using it would require users to recompile code that uses SRFI-9.  See
  72 ;; <http://lists.gnu.org/archive/html/guile-devel/2011-04/msg00111.html>.
  73 ;;
  74
  75 (define-syntax-rule (define-inlinable (name formals ...) body ...)
  76   (define-tagged-inlinable () (name formals ...) body ...))
  77
  78 ;; 'define-tagged-inlinable' has an additional feature: it stores a map
  79 ;; of keys to values that can be retrieved at expansion time.  This is
  80 ;; currently used to retrieve the rtd id, field index, and record copier
  81 ;; macro for an arbitrary getter.
  82
  83 (define-syntax-rule (%%on-error err) err)
  84
  85 (define %%type #f)   ; a private syntax literal
  86 (define-syntax getter-type
  87   (syntax-rules (quote)
  88     ((_ s 'getter 'err)
  89      (getter (%%on-error err) %%type s))))
  90
  91 (define %%index #f)  ; a private syntax literal
  92 (define-syntax getter-index
  93   (syntax-rules (quote)
  94    ((_ s 'getter 'err)
  95     (getter (%%on-error err) %%index s))))
  96
  97 (define %%copier #f) ; a private syntax literal
  98 (define-syntax getter-copier
  99   (syntax-rules (quote)
 100    ((_ s 'getter 'err)
 101     (getter (%%on-error err) %%copier s))))
 102
 103 (define-syntax define-tagged-inlinable
 104   (lambda (x)
 105     (define (make-procedure-name name)
 106       (datum->syntax name
 107                      (symbol-append '% (syntax->datum name)
 108                                     '-procedure)))
 109
 110     (syntax-case x ()
 111       ((_ ((key value) ...) (name formals ...) body ...)
 112        (identifier? #'name)
 113        (with-syntax ((proc-name  (make-procedure-name #'name))
 114                      ((args ...) (generate-temporaries #'(formals ...))))
 115          #`(begin
 116              (define (proc-name formals ...)
 117                body ...)
 118              (define-syntax name
 119                (lambda (x)
 120                  (syntax-case x (%%on-error key ...)
 121                    ((_ (%%on-error err) key s) #'(ck s 'value)) ...
 122                    ((_ args ...)
 123                     #'((lambda (formals ...)
 124                          body ...)
 125                        args ...))
 126                    ((_ a (... ...))
 127                     (syntax-violation 'name "Wrong number of arguments" x))
 128                    (_
 129                     (identifier? x)
 130                     #'proc-name))))))))))
 131
 132 (define (default-record-printer s p)
 133   (display "#<" p)
 134   (display (record-type-name (record-type-descriptor s)) p)
 135   (let loop ((fields (record-type-fields (record-type-descriptor s)))
 136              (off 0))
 137     (cond
 138      ((not (null? fields))
 139       (display " " p)
 140       (display (car fields) p)
 141       (display ": " p)
 142       (write (struct-ref s off) p)
 143       (loop (cdr fields) (+ 1 off)))))
 144   (display ">" p))
 145
 146 (define (throw-bad-struct s who)
 147   (throw 'wrong-type-arg who
 148          "Wrong type argument: ~S" (list s)
 149          (list s)))
 150
 151 (define (make-copier-id type-name)
 152   (datum->syntax type-name
 153                  (symbol-append '%% (syntax->datum type-name)
 154                                 '-set-fields)))
 155
 156 (define-syntax %%set-fields
 157   (lambda (x)
 158     (syntax-case x ()
 159       ((_ type-name (getter-id ...) check? s (getter expr) ...)
 160        (every identifier? #'(getter ...))
 161        (let ((copier-name (syntax->datum (make-copier-id #'type-name)))
 162              (getter+exprs #'((getter expr) ...)))
 163          (define (lookup id default-expr)
 164            (let ((results
 165                   (filter (lambda (g+e)
 166                             (free-identifier=? id (car g+e)))
 167                           getter+exprs)))
 168              (case (length results)
 169                ((0) default-expr)
 170                ((1) (cadar results))
 171                (else (syntax-violation
 172                       copier-name "duplicate getter" x id)))))
 173          (for-each (lambda (id)
 174                      (or (find (lambda (getter-id)
 175                                  (free-identifier=? id getter-id))
 176                                #'(getter-id ...))
 177                          (syntax-violation
 178                           copier-name "unknown getter" x id)))
 179                    #'(getter ...))
 180          (with-syntax ((unsafe-expr
 181                         #`(make-struct
 182                            type-name 0
 183                            #,@(map (lambda (getter index)
 184                                      (lookup getter #`(struct-ref s #,index)))
 185                                    #'(getter-id ...)
 186                                    (iota (length #'(getter-id ...)))))))
 187            (if (syntax->datum #'check?)
 188                #`(if (eq? (struct-vtable s) type-name)
 189                      unsafe-expr
 190                      (throw-bad-struct
 191                       s '#,(datum->syntax #'here copier-name)))
 192                #'unsafe-expr)))))))
 193
 194 (define-syntax %define-record-type
 195   (lambda (x)
 196     (define (field-identifiers field-specs)
 197       (map (lambda (field-spec)
 198              (syntax-case field-spec ()
 199                ((name getter) #'name)
 200                ((name getter setter) #'name)))
 201            field-specs))
 202
 203     (define (getter-identifiers field-specs)
 204       (map (lambda (field-spec)
 205              (syntax-case field-spec ()
 206                ((name getter) #'getter)
 207                ((name getter setter) #'getter)))
 208            field-specs))
 209
 210     (define (constructor form type-name constructor-spec field-names)
 211       (syntax-case constructor-spec ()
 212         ((ctor field ...)
 213          (every identifier? #'(field ...))
 214          (let ((ctor-args (map (lambda (field)
 215                                  (let ((name (syntax->datum field)))
 216                                    (or (memq name field-names)
 217                                        (syntax-violation
 218                                         (syntax-case form ()
 219                                           ((macro . args)
 220                                            (syntax->datum #'macro)))
 221                                         "unknown field in constructor spec"
 222                                         form field))
 223                                    (cons name field)))
 224                                #'(field ...))))
 225            #`(define-inlinable #,constructor-spec
 226                (make-struct #,type-name 0
 227                             #,@(map (lambda (name)
 228                                       (assq-ref ctor-args name))
 229                                     field-names)))))))
 230
 231     (define (getters type-name getter-ids copier-id)
 232       (map (lambda (getter index)
 233              #`(define-tagged-inlinable
 234                  ((%%type   #,type-name)
 235                   (%%index  #,index)
 236                   (%%copier #,copier-id))
 237                  (#,getter s)
 238                  (if (eq? (struct-vtable s) #,type-name)
 239                      (struct-ref s #,index)
 240                      (throw-bad-struct s '#,getter))))
 241            getter-ids
 242            (iota (length getter-ids))))
 243
 244     (define (copier type-name getter-ids copier-id)
 245       #`(define-syntax-rule
 246           (#,copier-id check? s (getter expr) (... ...))
 247           (%%set-fields #,type-name #,getter-ids
 248                         check? s (getter expr) (... ...))))
 249
 250     (define (setters type-name field-specs)
 251       (filter-map (lambda (field-spec index)
 252                     (syntax-case field-spec ()
 253                       ((name getter) #f)
 254                       ((name getter setter)
 255                        #`(define-inlinable (setter s val)
 256                            (if (eq? (struct-vtable s) #,type-name)
 257                                (struct-set! s #,index val)
 258                                (throw-bad-struct s 'setter))))))
 259                   field-specs
 260                   (iota (length field-specs))))
 261
 262     (define (functional-setters copier-id field-specs)
 263       (filter-map (lambda (field-spec index)
 264                     (syntax-case field-spec ()
 265                       ((name getter) #f)
 266                       ((name getter setter)
 267                        #`(define-inlinable (setter s val)
 268                            (#,copier-id #t s (getter val))))))
 269                   field-specs
 270                   (iota (length field-specs))))
 271
 272     (define (record-layout immutable? count)
 273       (let ((desc (if immutable? "pr" "pw")))
 274         (string-concatenate (make-list count desc))))
 275
 276     (syntax-case x ()
 277       ((_ immutable? form type-name constructor-spec predicate-name
 278           field-spec ...)
 279        (let ()
 280          (define (syntax-error message subform)
 281            (syntax-violation (syntax-case #'form ()
 282                                ((macro . args) (syntax->datum #'macro)))
 283                              message #'form subform))
 284          (and (boolean? (syntax->datum #'immutable?))
 285               (or (identifier? #'type-name)
 286                   (syntax-error "expected type name" #'type-name))
 287               (syntax-case #'constructor-spec ()
 288                 ((ctor args ...)
 289                  (every identifier? #'(ctor args ...))
 290                  #t)
 291                 (_ (syntax-error "invalid constructor spec"
 292                                  #'constructor-spec)))
 293               (or (identifier? #'predicate-name)
 294                   (syntax-error "expected predicate name" #'predicate-name))
 295               (every (lambda (spec)
 296                        (syntax-case spec ()
 297                          ((field getter) #t)
 298                          ((field getter setter) #t)
 299                          (_ (syntax-error "invalid field spec" spec))))
 300                      #'(field-spec ...))))
 301        (let* ((field-ids   (field-identifiers  #'(field-spec ...)))
 302               (getter-ids  (getter-identifiers #'(field-spec ...)))
 303               (field-count (length field-ids))
 304               (immutable?  (syntax->datum #'immutable?))
 305               (layout      (record-layout immutable? field-count))
 306               (field-names (map syntax->datum field-ids))
 307               (ctor-name   (syntax-case #'constructor-spec ()
 308                              ((ctor args ...) #'ctor)))
 309               (copier-id   (make-copier-id #'type-name)))
 310          #`(begin
 311              #,(constructor #'form #'type-name #'constructor-spec field-names)
 312
 313              (define type-name
 314                (let ((rtd (make-struct/no-tail
 315                            record-type-vtable
 316                            '#,(datum->syntax #'here (make-struct-layout layout))
 317                            default-record-printer
 318                            'type-name
 319                            '#,field-ids)))
 320                  (set-struct-vtable-name! rtd 'type-name)
 321                  (struct-set! rtd (+ 2 vtable-offset-user) #,ctor-name)
 322                  rtd))
 323
 324              (define-inlinable (predicate-name obj)
 325                (and (struct? obj)
 326                     (eq? (struct-vtable obj) type-name)))
 327
 328              #,@(getters #'type-name getter-ids copier-id)
 329              #,(copier #'type-name getter-ids copier-id)
 330              #,@(if immutable?
 331                     (functional-setters copier-id #'(field-spec ...))
 332                     (setters #'type-name #'(field-spec ...))))))
 333       ((_ immutable? form . rest)
 334        (syntax-violation
 335         (syntax-case #'form ()
 336           ((macro . args) (syntax->datum #'macro)))
 337         "invalid record definition syntax"
 338         #'form)))))
 339
 340 (define-syntax-rule (define-record-type name ctor pred fields ...)
 341   (%define-record-type #f (define-record-type name ctor pred fields ...)
 342                        name ctor pred fields ...))
 343
 344 ;;; srfi-9.scm ends here