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