d0a8345ccaccb5c9418cc482caa336345407948d
[mes.git] / module / srfi / srfi-9.mes
1 ;;; -*-scheme-*-
2
3 ;;; Mes --- Maxwell Equations of Software
4 ;;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees.
5 ;;; Copyright © 2016 Jan Nieuwenhuizen <janneke@gnu.org>
6 ;;;
7 ;;; base-0.mes: This file is part of Mes.
8 ;;;
9 ;;; Mes is free software; you can redistribute it and/or modify it
10 ;;; under the terms of the GNU General Public License as published by
11 ;;; the Free Software Foundation; either version 3 of the License, or (at
12 ;;; your option) any later version.
13 ;;;
14 ;;; Mes is distributed in the hope that it will be useful, but
15 ;;; WITHOUT ANY WARRANTY; without even the implied warranty of
16 ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
17 ;;; GNU General Public License for more details.
18 ;;;
19 ;;; You should have received a copy of the GNU General Public License
20 ;;; along with Mes.  If not, see <http://www.gnu.org/licenses/>.
21
22 ;;; Commentary:
23
24 ;;; srfi-9.mes - records.  Assumes record-0.mes and record.mes are
25 ;;; available.  Modified from
26 ;;; scheme48-1.1/scheme/alt/jar-defrecord.scm to implement SRFI-9.
27
28 ;;; Code:
29
30 ;;; Copyright (c) 1993-2004 by Richard Kelsey and Jonathan Rees. See file COPYING.
31
32 ;;; scheme48-1.1/COPYING
33
34 ;; Copyright (c) 1993-2004 Richard Kelsey and Jonathan Rees
35 ;; All rights reserved.
36
37 ;; Redistribution and use in source and binary forms, with or without
38 ;; modification, are permitted provided that the following conditions
39 ;; are met:
40 ;; 1. Redistributions of source code must retain the above copyright
41 ;;    notice, this list of conditions and the following disclaimer.
42 ;; 2. Redistributions in binary form must reproduce the above copyright
43 ;;    notice, this list of conditions and the following disclaimer in the
44 ;;    documentation and/or other materials provided with the distribution.
45 ;; 3. The name of the authors may not be used to endorse or promote products
46 ;;    derived from this software without specific prior written permission.
47
48 ;; THIS SOFTWARE IS PROVIDED BY THE AUTHORS ``AS IS'' AND ANY EXPRESS OR
49 ;; IMPLIED WARRANTIES, INCLUDING, BUT NOT LIMITED TO, THE IMPLIED WARRANTIES
50 ;; OF MERCHANTABILITY AND FITNESS FOR A PARTICULAR PURPOSE ARE DISCLAIMED.
51 ;; IN NO EVENT SHALL THE AUTHORS BE LIABLE FOR ANY DIRECT, INDIRECT,
52 ;; INCIDENTAL, SPECIAL, EXEMPLARY, OR CONSEQUENTIAL DAMAGES (INCLUDING, BUT
53 ;; NOT LIMITED TO, PROCUREMENT OF SUBSTITUTE GOODS OR SERVICES; LOSS OF USE,
54 ;; DATA, OR PROFITS; OR BUSINESS INTERRUPTION) HOWEVER CAUSED AND ON ANY
55 ;; THEORY OF LIABILITY, WHETHER IN CONTRACT, STRICT LIABILITY, OR TORT
56 ;; (INCLUDING NEGLIGENCE OR OTHERWISE) ARISING IN ANY WAY OUT OF THE USE OF
57 ;; THIS SOFTWARE, EVEN IF ADVISED OF THE POSSIBILITY OF SUCH DAMAGE.
58
59 ; This is JAR's define-record-type, which doesn't resemble Richard's.
60
61 ; There's no implicit name concatenation, so it can be defined
62 ; entirely using syntax-rules.  Example:
63 ;  (define-record-type foo :foo
64 ;    (make-foo x y)
65 ;    foo?              - predicate name is optional
66 ;    (x foo-x)
67 ;    (y foo-y)
68 ;    (z foo-z set-foo-z!))
69
70 (define-syntax define-record-type
71   (syntax-rules ()
72     ((define-record-type type
73        (constructor arg ...)
74        (field . field-stuff)
75        ...)
76      (begin (define type (make-record-type 'type '(field ...)))
77             (define constructor (record-constructor type '(arg ...)))
78             (define-accessors type (field . field-stuff) ...)))
79     ((define-record-type type
80        (constructor arg ...)
81        pred
82        more ...)
83      (begin (define-record-type type
84               (constructor arg ...)
85               more ...)
86             (define pred (record-predicate type))))))
87
88 ;; Straightforward version
89 (define-syntax define-accessors
90   (syntax-rules ()
91     ((define-accessors type field-spec ...)
92      (begin (define-accessor type . field-spec) ...))))
93
94 (define-syntax define-accessor
95   (syntax-rules ()
96     ((define-accessor type field accessor)
97      (define accessor (record-accessor type 'field)))
98     ((define-accessor type field accessor modifier)
99      (begin (define accessor (record-accessor type 'field))
100             (define modifier (record-modifier type 'field))))))