srfi/srfi-9.scm

   1 ;;;; srfi-9.scm --- SRFI-9 procedures for Guile
   2 ;;;;
   3 ;;;;    Copyright (C) 2001 Free Software Foundation, Inc.
   4 ;;;;
   5 ;;;; This program is free software; you can redistribute it and/or
   6 ;;;; modify it under the terms of the GNU General Public License as
   7 ;;;; published by the Free Software Foundation; either version 2, or
   8 ;;;; (at your option) any later version.
   9 ;;;;
  10 ;;;; This program 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 ;;;; General Public License for more details.
  14 ;;;;
  15 ;;;; You should have received a copy of the GNU General Public License
  16 ;;;; along with this software; see the file COPYING.  If not, write to
  17 ;;;; the Free Software Foundation, Inc., 59 Temple Place, Suite 330,
  18 ;;;; Boston, MA 02111-1307 USA
  19 ;;;;
  20 ;;;; As a special exception, the Free Software Foundation gives permission
  21 ;;;; for additional uses of the text contained in its release of GUILE.
  22 ;;;;
  23 ;;;; The exception is that, if you link the GUILE library with other files
  24 ;;;; to produce an executable, this does not by itself cause the
  25 ;;;; resulting executable to be covered by the GNU General Public License.
  26 ;;;; Your use of that executable is in no way restricted on account of
  27 ;;;; linking the GUILE library code into it.
  28 ;;;;
  29 ;;;; This exception does not however invalidate any other reasons why
  30 ;;;; the executable file might be covered by the GNU General Public License.
  31 ;;;;
  32 ;;;; This exception applies only to the code released by the
  33 ;;;; Free Software Foundation under the name GUILE.  If you copy
  34 ;;;; code from other Free Software Foundation releases into a copy of
  35 ;;;; GUILE, as the General Public License permits, the exception does
  36 ;;;; not apply to the code that you add in this way.  To avoid misleading
  37 ;;;; anyone as to the status of such modified files, you must delete
  38 ;;;; this exception notice from them.
  39 ;;;;
  40 ;;;; If you write modifications of your own for GUILE, it is your choice
  41 ;;;; whether to permit this exception to apply to your modifications.
  42 ;;;; If you do not wish that, delete this exception notice.
  43
  44 ;;; Commentary:
  45
  46 ;;; This module exports the syntactic form `define-record-type', which
  47 ;;; is the means for creating record types defined in SRFI-9.
  48 ;;;
  49 ;;; The syntax of a record type definition is:
  50 ;;;
  51 ;;;  <record type definition>
  52 ;;;    -> (define-record-type <type name>
  53 ;;;         (<constructor name> <field tag> ...)
  54 ;;;         <predicate name>
  55 ;;;         <field spec> ...)
  56 ;;;
  57 ;;;  <field spec> -> (<field tag> <accessor name>)
  58 ;;;               -> (<field tag> <accessor name> <modifier name>)
  59 ;;;
  60 ;;;  <field tag> -> <identifier>
  61 ;;;  <... name>  -> <identifier>
  62 ;;;
  63 ;;; Usage example:
  64 ;;;
  65 ;;; guile> (use-modules (srfi srfi-9))
  66 ;;; guile> (define-record-type :foo (make-foo x) foo?
  67 ;;;                            (x get-x) (y get-y set-y!))
  68 ;;; guile> (define f (make-foo 1))
  69 ;;; guile> f
  70 ;;; #<:foo x: 1 y: #f>
  71 ;;; guile> (get-x f)
  72 ;;; 1
  73 ;;; guile> (set-y! f 2)
  74 ;;; 2
  75 ;;; guile> (get-y f)
  76 ;;; 2
  77 ;;; guile> f
  78 ;;; #<:foo x: 1 y: 2>
  79 ;;; guile> (foo? f)
  80 ;;; #t
  81 ;;; guile> (foo? 1)
  82 ;;; #f
  83
  84 ;;; Code:
  85
  86 (define-module (srfi srfi-9)
  87   :export-syntax (define-record-type))
  88
  89 (cond-expand-provide (current-module) '(srfi-9))
  90
  91 (define-macro (define-record-type type-name constructor/field-tag
  92                 predicate-name . field-specs)
  93   `(begin
  94      (define ,type-name
  95        (make-record-type ',type-name ',(map car field-specs)))
  96      (define ,(car constructor/field-tag)
  97        (record-constructor ,type-name ',(cdr constructor/field-tag)))
  98      (define ,predicate-name
  99        (record-predicate ,type-name))
 100      ,@(map
 101         (lambda (spec)
 102           (cond
 103            ((= (length spec) 2)
 104             `(define ,(cadr spec)
 105                (record-accessor ,type-name ',(car spec))))
 106            ((= (length spec) 3)
 107             `(begin
 108                (define ,(cadr spec)
 109                  (record-accessor ,type-name ',(car spec)))
 110                (define ,(caddr spec)
 111                  (record-modifier ,type-name ',(car spec)))))
 112            (else
 113             (error "invalid field spec " spec))))
 114         field-specs)))