1;; Copyright (C) Richard Kelsey (1999). All Rights Reserved.
2;;
3;; Permission is hereby granted, free of charge, to any person obtaining
4;; a copy of this software and associated documentation files (the
5;; "Software"), to deal in the Software without restriction, including
6;; without limitation the rights to use, copy, modify, merge, publish,
7;; distribute, sublicense, and/or sell copies of the Software, and to
8;; permit persons to whom the Software is furnished to do so, subject to
9;; the following conditions:
10;;
11;; The above copyright notice and this permission notice shall be
12;; included in all copies or substantial portions of the Software.
13;;
14;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND,
15;; EXPRESS OR IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF
16;; MERCHANTABILITY, FITNESS FOR A PARTICULAR PURPOSE AND
17;; NONINFRINGEMENT. IN NO EVENT SHALL THE AUTHORS OR COPYRIGHT HOLDERS BE
18;; LIABLE FOR ANY CLAIM, DAMAGES OR OTHER LIABILITY, WHETHER IN AN ACTION
19;; OF CONTRACT, TORT OR OTHERWISE, ARISING FROM, OUT OF OR IN CONNECTION
20;; WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE SOFTWARE.
21
22
23;; ChangeLog
24;;
25;; 2007-07-23 yamaken   - Imported from
26;;                        http://srfi.schemers.org/srfi-9/srfi-9.html
27;;                        and adapted to SigScheme
28;; 2007-09-04 yamaken   - Fix  (real-eval `(lambda (vector?) ,exp))
29;;                        with (real-eval `(lambda (vector?) ,exp) env)
30;;                      - Suppress overriding of 'eval' since current SigScheme
31;;                        implementation (0.8.0) does not need the vector?
32;;                        trick. It allows (interaction-environment).
33
34
35;; This code is divided into three layers. In top-down order these are:
36;;
37;;    1. Syntax definitions for DEFINE-RECORD-TYPE and an auxillary macro.
38;;    2. An implementation of record types with a procedural interface. Some
39;;       Scheme implementations already have something close to this.
40;;    3. Vector-like records implemented in R5RS. This redefines some standard
41;;       Scheme procedures and therefor must be loaded before any other code,
42;;       including part 2 above. Note that these procedures can be used to
43;;       break the record-type abstraction (for example, RECORD-SET! can be
44;;       used to modify the type of a record). Access to these procedures
45;;       should be restricted.
46
47
48;;
49;; Syntax definitions
50;;
51
52; Definition of DEFINE-RECORD-TYPE
53
54;;(define-syntax define-record-type
55;;  (syntax-rules ()
56;;    ((define-record-type type
57;;       (constructor constructor-tag ...)
58;;       predicate
59;;       (field-tag accessor . more) ...)
60;;     (begin
61;;       (define type
62;;         (make-record-type 'type '(field-tag ...)))
63;;       (define constructor
64;;         (record-constructor type '(constructor-tag ...)))
65;;       (define predicate
66;;         (record-predicate type))
67;;       (define-record-field type field-tag accessor . more)
68;;       ...))))
69
70; An auxilliary macro for define field accessors and modifiers.
71; This is needed only because modifiers are optional.
72
73;;(define-syntax define-record-field
74;;  (syntax-rules ()
75;;    ((define-record-field type field-tag accessor)
76;;     (define accessor (record-accessor type 'field-tag)))
77;;    ((define-record-field type field-tag accessor modifier)
78;;     (begin
79;;       (define accessor (record-accessor type 'field-tag))
80;;       (define modifier (record-modifier type 'field-tag))))))
81
82
83;;
84;; Records
85;;
86
87; This implements a record abstraction that is identical to vectors,
88; except that they are not vectors (VECTOR? returns false when given a
89; record and RECORD? returns false when given a vector).  The following
90; procedures are provided:
91;   (record? <value>)                -> <boolean>
92;   (make-record <size>)             -> <record>
93;   (record-ref <record> <index>)    -> <value>
94;   (record-set! <record> <index> <value>) -> <unspecific>
95;
96; These can implemented in R5RS Scheme as vectors with a distinguishing
97; value at index zero, providing VECTOR? is redefined to be a procedure
98; that returns false if its argument contains the distinguishing record
99; value.  EVAL is also redefined to use the new value of VECTOR?.
100
101; Define the marker and redefine VECTOR? and EVAL.
102
103(define record-marker (list 'record-marker))
104
105(define real-vector? vector?)
106
107(define (vector? x)
108  (and (real-vector? x)
109       (or (= 0 (vector-length x))
110	   (not (eq? (vector-ref x 0)
111		record-marker)))))
112
113(cond-expand
114 (sigscheme
115  ;; Current SigScheme implementation does not need the vector? trick.
116  #t)
117 (else
118; This won't work if ENV is the interaction environment and someone has
119; redefined LAMBDA there.
120
121(define eval
122  (let ((real-eval eval))
123    (lambda (exp env)
124      ((real-eval `(lambda (vector?) ,exp) env)
125       vector?))))
126))
127
128; Definitions of the record procedures.
129
130(define (record? x)
131  (and (real-vector? x)
132       (< 0 (vector-length x))
133       (eq? (vector-ref x 0)
134            record-marker)))
135
136(define (make-record size)
137  (let ((new (make-vector (+ size 1))))
138    (vector-set! new 0 record-marker)
139    new))
140
141(define (record-ref record index)
142  (vector-ref record (+ index 1)))
143
144(define (record-set! record index value)
145  (vector-set! record (+ index 1) value))
146
147
148;;
149;; Record types
150;;
151
152; We define the following procedures:
153;
154; (make-record-type <type-name> <field-names>)     -> <record-type>
155; (record-constructor <record-type> <field-names>) -> <constructor>
156; (record-predicate <record-type>)                 -> <predicate>
157; (record-accessor <record-type <field-name>)      -> <accessor>
158; (record-modifier <record-type <field-name>)      -> <modifier>
159;   where
160; (<constructor> <initial-value> ...)         -> <record>
161; (<predicate> <value>)                       -> <boolean>
162; (<accessor> <record>)                       -> <value>
163; (<modifier> <record> <value>)         -> <unspecific>
164
165; Record types are implemented using vector-like records.  The first
166; slot of each record contains the record's type, which is itself a
167; record.
168
169(define (record-type record)
170  (record-ref record 0))
171
172;----------------
173; Record types are themselves records, so we first define the type for
174; them.  Except for problems with circularities, this could be defined as:
175;  (define-record-type :record-type
176;    (make-record-type name field-tags)
177;    record-type?
178;    (name record-type-name)
179;    (field-tags record-type-field-tags))
180; As it is, we need to define everything by hand.
181
182(define :record-type (make-record 3))
183(record-set! :record-type 0 :record-type)	; Its type is itself.
184(record-set! :record-type 1 ':record-type)
185(record-set! :record-type 2 '(name field-tags))
186
187; Now that :record-type exists we can define a procedure for making more
188; record types.
189
190(define (make-record-type name field-tags)
191  (let ((new (make-record 3)))
192    (record-set! new 0 :record-type)
193    (record-set! new 1 name)
194    (record-set! new 2 field-tags)
195    new))
196
197; Accessors for record types.
198
199(define (record-type-name record-type)
200  (record-ref record-type 1))
201
202(define (record-type-field-tags record-type)
203  (record-ref record-type 2))
204
205;----------------
206; A utility for getting the offset of a field within a record.
207
208(define (field-index type tag)
209  (let loop ((i 1) (tags (record-type-field-tags type)))
210    (cond ((null? tags)
211           (error "record type has no such field" type tag))
212          ((eq? tag (car tags))
213           i)
214          (else
215           (loop (+ i 1) (cdr tags))))))
216
217;----------------
218; Now we are ready to define RECORD-CONSTRUCTOR and the rest of the
219; procedures used by the macro expansion of DEFINE-RECORD-TYPE.
220
221(define (record-constructor type tags)
222  (let ((size (length (record-type-field-tags type)))
223        (arg-count (length tags))
224        (indexes (map (lambda (tag)
225                        (field-index type tag))
226                      tags)))
227    (lambda args
228      (if (= (length args)
229             arg-count)
230          (let ((new (make-record (+ size 1))))
231            (record-set! new 0 type)
232            (for-each (lambda (arg i)
233			(record-set! new i arg))
234                      args
235                      indexes)
236            new)
237          (error "wrong number of arguments to constructor" type args)))))
238
239(define (record-predicate type)
240  (lambda (thing)
241    (and (record? thing)
242         (eq? (record-type thing)
243              type))))
244
245(define (record-accessor type tag)
246  (let ((index (field-index type tag)))
247    (lambda (thing)
248      (if (and (record? thing)
249               (eq? (record-type thing)
250                    type))
251          (record-ref thing index)
252          (error "accessor applied to bad value" type tag thing)))))
253
254(define (record-modifier type tag)
255  (let ((index (field-index type tag)))
256    (lambda (thing value)
257      (if (and (record? thing)
258               (eq? (record-type thing)
259                    type))
260          (record-set! thing index value)
261          (error "modifier applied to bad value" type tag thing)))))
262