Add loadable modules.
[mes.git] / module / mes / record.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 ;;; 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 ;;; record.mes is loaded after record-0.mes.  It provides a
25 ;;; nonstandard record type that SRFI-9 can be trivially implemented
26 ;;; on.  Adapted from scheme48-1.1/scheme/rts/record.scm
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 ;;;; Records
60
61 ; Every record in the image is assumed to be made either by MAKE-RECORD-TYPE
62 ; or by a procedure returned by record-constructor.  A record-type is a
63 ; record that describes a type of record.  At the end of the file we create
64 ; a record type that describes record types.
65
66 ; We number the record types for debugging purposes.
67
68 (define *record-type-uid* -1)
69
70 ; This is the record type that describes record types.  It is set a the end
71 ; of the file.  Its first slot points to itself.
72
73 (define *record-type* #f)
74
75 ; Make a record type from a name, used for printing and debugging, and
76 ; a list of field names.
77 ;
78 ; The VM references both the record type and the resumer, so their offsets
79 ; should not be changed.
80
81 (define (make-record-type name field-names)
82   (set! *record-type-uid* (+ *record-type-uid* 1))
83   (let ((r (make-record 7 (unspecific))))
84     (record-set! r 0 *record-type*)
85     (record-set! r 1 default-record-resumer)
86     (record-set! r 2 *record-type-uid*)
87     (record-set! r 3 name)
88     (record-set! r 4 field-names)
89     (record-set! r 5 (length field-names))
90     (record-set! r 6 (make-default-record-discloser name))
91     r))
92
93 (define (record-type? obj)
94   (and (record? obj)
95        (eq? (record-type obj) *record-type*)))
96
97 ; The various fields in a record type.
98
99 (define (record-type-resumer rt)          (record-ref rt 1))
100 (define (set-record-type-resumer! rt r)   (record-set! rt 1 r))
101 (define (record-type-uid rt)              (record-ref rt 2))
102 (define (record-type-name rt)             (record-ref rt 3))
103 (define (record-type-field-names rt)      (record-ref rt 4))
104 (define (record-type-number-of-fields rt) (record-ref rt 5))
105 (define (record-type-discloser rt)        (record-ref rt 6))
106 (define (set-record-type-discloser! rt d) (record-set! rt 6 d))
107
108 ; This is a hack; it is read by the script that makes c/scheme48.h.
109
110 (define record-type-fields
111   '(resumer uid name field-names number-of-fields discloser))
112
113 ;----------------
114 ; Given a record type and the name of a field, return the field's index.
115
116 (define (record-field-index rt name)
117   (let loop ((names (record-type-field-names rt))
118              (i 1))
119     (cond ((null? names)
120            (error "unknown field"
121                   (record-type-name rt)
122                   name))
123           ((eq? name (car names))
124            i)
125           (else
126            (loop (cdr names) (+ i 1))))))
127
128 ; Return procedure for contstruction records of type RT.  NAMES is a list of
129 ; field names which the constructor will take as arguments.  Other fields are
130 ; uninitialized.
131
132 (define (record-constructor rt names)
133   (let ((indexes (map (lambda (name)
134                         (record-field-index rt name))
135                       names))
136         (size (+ 1 (record-type-number-of-fields rt))))
137     (lambda args
138       (let ((r (make-record size (unspecific))))
139         (record-set! r 0 rt)
140         (let loop ((is indexes) (as args))
141           (if (null? as)
142               (if (null? is)
143                   r
144                   (error "too few arguments to record constructor"
145                          rt names args))
146               (if (null? is)
147                   (error "too many arguments to record constructor"
148                          rt names args)
149                   (begin (record-set! r (car is) (car as))
150                          (loop (cdr is) (cdr as))))))))))
151
152 ; Making accessors, modifiers, and predicates for record types.
153
154 (define (record-accessor rt name)
155   (let ((index (record-field-index rt name))
156         (error-cruft `(record-accessor ,rt ',name)))
157     (lambda (r)
158       (if (eq? (record-type r) rt)
159           (record-ref r index)
160           (call-error "invalid record access" error-cruft r)))))
161
162 (define (record-modifier rt name)
163   (let ((index (record-field-index rt name))
164         (error-cruft `(record-modifier ,rt ',name)))
165     (lambda (r x)
166       (if (eq? (record-type r) rt)
167           (record-set! r index x)
168           (call-error "invalid record modification" error-cruft r x)))))
169
170 (define (record-predicate rt)
171   (lambda (x)
172     (and (record? x)
173          (eq? (record-type x) rt))))
174
175 ;----------------
176 ; A discloser is a procedure that takes a record of a particular type and
177 ; returns a list whose head is a string or symbol and whose tail is other
178 ; stuff.
179 ;
180 ; Set the discloser for record type RT.
181
182 (define (define-record-discloser rt proc)
183   (if (and (record-type? rt)
184            (procedure? proc))
185       (set-record-type-discloser! rt proc)
186       (call-error "invalid argument" define-record-discloser rt proc)))
187
188 ; By default we just return the name of the record type.
189
190 (define (make-default-record-discloser record-type-name)
191   (lambda (r)
192     (list record-type-name)))
193
194 ; DISCLOSE-RECORD calls the record's discloser procedure to obtain a list.
195
196 (define (disclose-record r)
197   (if (record? r)
198       (let ((rt (record-type r)))
199         (if (record-type? rt)
200             ((record-type-discloser rt) r)
201             #f))
202       #f))
203
204 ;----------------
205 ; A resumer is a procedure that the VM calls on all records of a given
206 ; type on startup.
207 ;
208 ; A resumer may be:
209 ;  #t -> do nothing on startup.
210 ;  #f -> records of this type do not survive a dump/resume; in images they
211 ;        are replaced by their first slot (so we make sure they have one)
212 ;  a one-argument procedure -> pass the record to this procedure
213 ;
214 ; Resumers are primarily intended for use by external code which keeps
215 ; fields in records which do not survive a dump under their own power.
216 ; For example, a record may contain a reference to a OS-dependent value.
217 ;
218 ; Resumers are called by the VM on startup.
219
220 (define (define-record-resumer rt resumer)
221   (if (and (record-type? rt)
222            (or (eq? #t resumer)
223                (and (eq? #f resumer)
224                     (< 0 (record-type-number-of-fields rt)))
225                (procedure? resumer)))
226       (set-record-type-resumer! rt resumer)
227       (call-error "invalid argument" define-record-resumer rt resumer)))
228
229 ; By default we leave records alone.
230
231 (define default-record-resumer
232   #t)
233
234 (define (initialize-records! resumer-records)
235   (if (vector? resumer-records)
236       (do ((i 0 (+ i 1)))
237           ((= i (vector-length resumer-records)))
238         (resume-record (vector-ref resumer-records i)))))
239
240 (define (resume-record record)
241   ((record-type-resumer (record-type record))
242      record))
243
244 ;----------------
245 ; Initializing *RECORD-TYPE* and making a type.
246
247 (set! *record-type*
248       (make-record-type 'record-type record-type-fields))
249
250 (record-set! *record-type* 0 *record-type*)
251
252 (define :record-type *record-type*)
253
254 (define-record-discloser :record-type
255   (lambda (rt)
256     (list 'record-type
257           (record-type-uid rt)
258           (record-type-name rt))))