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, 2014 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-syntax-rule (throw-bad-struct s who)
 147   (let ((s* s))
 148     (throw 'wrong-type-arg who
 149            "Wrong type argument: ~S" (list s*)
 150            (list s*))))
 151
 152 (define (make-copier-id type-name)
 153   (datum->syntax type-name
 154                  (symbol-append '%% (syntax->datum type-name)
 155                                 '-set-fields)))
 156
 157 (define-syntax %%set-fields
 158   (lambda (x)
 159     (syntax-case x ()
 160       ((_ type-name (getter-id ...) check? s (getter expr) ...)
 161        (every identifier? #'(getter ...))
 162        (let ((copier-name (syntax->datum (make-copier-id #'type-name)))
 163              (getter+exprs #'((getter expr) ...))
 164              (nfields (length #'(getter-id ...))))
 165          (define (lookup id default-expr)
 166            (let ((results
 167                   (filter (lambda (g+e)
 168                             (free-identifier=? id (car g+e)))
 169                           getter+exprs)))
 170              (case (length results)
 171                ((0) default-expr)
 172                ((1) (cadar results))
 173                (else (syntax-violation
 174                       copier-name "duplicate getter" x id)))))
 175          (for-each (lambda (id)
 176                      (or (find (lambda (getter-id)
 177                                  (free-identifier=? id getter-id))
 178                                #'(getter-id ...))
 179                          (syntax-violation
 180                           copier-name "unknown getter" x id)))
 181                    #'(getter ...))
 182          (with-syntax ((unsafe-expr
 183                         #`(let ((new (allocate-struct type-name #,nfields)))
 184                             #,@(map (lambda (getter index)
 185                                       #`(struct-set!
 186                                          new
 187                                          #,index
 188                                          #,(lookup getter
 189                                                    #`(struct-ref s #,index))))
 190                                     #'(getter-id ...)
 191                                     (iota nfields))
 192                             new)))
 193            (if (syntax->datum #'check?)
 194                #`(if (eq? (struct-vtable s) type-name)
 195                      unsafe-expr
 196                      (throw-bad-struct
 197                       s '#,(datum->syntax #'here copier-name)))
 198                #'unsafe-expr)))))))
 199
 200 (define-syntax %define-record-type
 201   (lambda (x)
 202     (define (field-identifiers field-specs)
 203       (map (lambda (field-spec)
 204              (syntax-case field-spec ()
 205                ((name getter) #'name)
 206                ((name getter setter) #'name)))
 207            field-specs))
 208
 209     (define (getter-identifiers field-specs)
 210       (map (lambda (field-spec)
 211              (syntax-case field-spec ()
 212                ((name getter) #'getter)
 213                ((name getter setter) #'getter)))
 214            field-specs))
 215
 216     (define (constructor form type-name constructor-spec field-ids)
 217       (syntax-case constructor-spec ()
 218         ((ctor field ...)
 219          (every identifier? #'(field ...))
 220          (let ((slots (map (lambda (field)
 221                              (or (list-index (lambda (x)
 222                                                (free-identifier=? x field))
 223                                              field-ids)
 224                                  (syntax-violation
 225                                   (syntax-case form ()
 226                                     ((macro . args)
 227                                      (syntax->datum #'macro)))
 228                                   "unknown field in constructor spec"
 229                                   form field)))
 230                            #'(field ...))))
 231            #`(define-inlinable #,constructor-spec
 232                (let ((s (allocate-struct #,type-name #,(length field-ids))))
 233                  #,@(map (lambda (arg slot)
 234                            #`(struct-set! s #,slot #,arg))
 235                          #'(field ...) slots)
 236                  s))))))
 237
 238     (define (getters type-name getter-ids copier-id)
 239       (map (lambda (getter index)
 240              #`(define-tagged-inlinable
 241                  ((%%type   #,type-name)
 242                   (%%index  #,index)
 243                   (%%copier #,copier-id))
 244                  (#,getter s)
 245                  (if (eq? (struct-vtable s) #,type-name)
 246                      (struct-ref s #,index)
 247                      (throw-bad-struct s '#,getter))))
 248            getter-ids
 249            (iota (length getter-ids))))
 250
 251     (define (copier type-name getter-ids copier-id)
 252       #`(define-syntax-rule
 253           (#,copier-id check? s (getter expr) (... ...))
 254           (%%set-fields #,type-name #,getter-ids
 255                         check? s (getter expr) (... ...))))
 256
 257     (define (setters type-name field-specs)
 258       (filter-map (lambda (field-spec index)
 259                     (syntax-case field-spec ()
 260                       ((name getter) #f)
 261                       ((name getter setter)
 262                        #`(define-inlinable (setter s val)
 263                            (if (eq? (struct-vtable s) #,type-name)
 264                                (struct-set! s #,index val)
 265                                (throw-bad-struct s 'setter))))))
 266                   field-specs
 267                   (iota (length field-specs))))
 268
 269     (define (functional-setters copier-id field-specs)
 270       (filter-map (lambda (field-spec index)
 271                     (syntax-case field-spec ()
 272                       ((name getter) #f)
 273                       ((name getter setter)
 274                        #`(define-inlinable (setter s val)
 275                            (#,copier-id #t s (getter val))))))
 276                   field-specs
 277                   (iota (length field-specs))))
 278
 279     (define (record-layout immutable? count)
 280       ;; Mutability is expressed on the record level; all structs in the
 281       ;; future will be mutable.
 282       (string-concatenate (make-list count "pw")))
 283
 284     (syntax-case x ()
 285       ((_ immutable? form type-name constructor-spec predicate-name
 286           field-spec ...)
 287        (let ()
 288          (define (syntax-error message subform)
 289            (syntax-violation (syntax-case #'form ()
 290                                ((macro . args) (syntax->datum #'macro)))
 291                              message #'form subform))
 292          (and (boolean? (syntax->datum #'immutable?))
 293               (or (identifier? #'type-name)
 294                   (syntax-error "expected type name" #'type-name))
 295               (syntax-case #'constructor-spec ()
 296                 ((ctor args ...)
 297                  (every identifier? #'(ctor args ...))
 298                  #t)
 299                 (_ (syntax-error "invalid constructor spec"
 300                                  #'constructor-spec)))
 301               (or (identifier? #'predicate-name)
 302                   (syntax-error "expected predicate name" #'predicate-name))
 303               (every (lambda (spec)
 304                        (syntax-case spec ()
 305                          ((field getter) #t)
 306                          ((field getter setter) #t)
 307                          (_ (syntax-error "invalid field spec" spec))))
 308                      #'(field-spec ...))))
 309        (let* ((field-ids   (field-identifiers  #'(field-spec ...)))
 310               (getter-ids  (getter-identifiers #'(field-spec ...)))
 311               (field-count (length field-ids))
 312               (immutable?  (syntax->datum #'immutable?))
 313               (layout      (record-layout immutable? field-count))
 314               (ctor-name   (syntax-case #'constructor-spec ()
 315                              ((ctor args ...) #'ctor)))
 316               (copier-id   (make-copier-id #'type-name)))
 317          #`(begin
 318              #,(constructor #'form #'type-name #'constructor-spec field-ids)
 319
 320              (define type-name
 321                (let ((rtd (make-struct/no-tail
 322                            record-type-vtable
 323                            '#,(datum->syntax #'here (make-struct-layout layout))
 324                            default-record-printer
 325                            'type-name
 326                            '#,field-ids)))
 327                  (set-struct-vtable-name! rtd 'type-name)
 328                  (struct-set! rtd (+ 2 vtable-offset-user) #,ctor-name)
 329                  rtd))
 330
 331              (define-inlinable (predicate-name obj)
 332                (and (struct? obj)
 333                     (eq? (struct-vtable obj) type-name)))
 334
 335              #,@(getters #'type-name getter-ids copier-id)
 336              #,(copier #'type-name getter-ids copier-id)
 337              #,@(if immutable?
 338                     (functional-setters copier-id #'(field-spec ...))
 339                     (setters #'type-name #'(field-spec ...))))))
 340       ((_ immutable? form . rest)
 341        (syntax-violation
 342         (syntax-case #'form ()
 343           ((macro . args) (syntax->datum #'macro)))
 344         "invalid record definition syntax"
 345         #'form)))))
 346
 347 (define-syntax-rule (define-record-type name ctor pred fields ...)
 348   (%define-record-type #f (define-record-type name ctor pred fields ...)
 349                        name ctor pred fields ...))
 350
 351 ;;; srfi-9.scm ends here