source: project/release/5/records/trunk/records.scm @ 36400

Last change on this file since 36400 was 36400, checked in by Kooda, 18 months ago

Port the records egg to CHICKEN 5

File size: 4.0 KB
Line 
1; "record.scm" record data types
2; Written by David Carlton, carlton@husc.harvard.edu.
3; Re-Written by Aubrey Jaffer, agj @ alum.mit.edu, 1996, 1997
4;
5; This code is in the public domain.
6
7; Implements `record' data structures for Scheme.  Using only the
8; opacity of procedures, makes record datatypes and
9; record-type-descriptors disjoint from R4RS types and each other, and
10; prevents forgery and corruption (modification without using
11; RECORD-MODIFIER) of records.
12
13;;2001-07-24  Aubrey Jaffer  <agj@alum.mit.edu>
14;;  changed identifiers containing VECTOR to VECT or VCT.
15
16;; Ported to CHICKEN by felix
17
18(declare 
19  (fixnum)
20  (no-bound-checks) )
21
22(module records
23
24  (record-modifier 
25          record-accessor
26          record-constructor
27          record-predicate
28          make-record-type) 
29
30(import scheme (chicken base) (chicken fixnum) srfi-1)
31
32(define (rtd? x) (##sys#structure? x 'rtd))
33(define (rtd-name rtd) (##sys#slot rtd 1))
34(define (rtd-fields rtd) (##sys#slot rtd 2))
35(define (rtd-length rtd) (##sys#slot rtd 3))
36
37(define (has-duplicates? lst)
38  (cond ((null? lst) #f)
39        ((memq (car lst) (cdr lst)) #t)
40        (else (has-duplicates? (cdr lst)))))
41
42(define make-record-type
43  (lambda (type-name field-names)
44    (if (string? type-name)
45        (set! type-name (string->symbol type-name))
46        (##sys#check-symbol type-name 'make-record-type) )
47    (if (or (and (list? field-names) (has-duplicates? field-names))
48            (not (every symbol? field-names)))
49        (error 'make-record-type "illegal field-names argument"
50               field-names))
51    (##sys#make-structure
52     'rtd
53     type-name
54     field-names
55     (length field-names) ) ) )
56
57(define record-predicate
58  (lambda (rtd)
59    (if (not (rtd? rtd))
60        (error 'record-predicate "invalid argument - not a record type" rtd))
61    (lambda (x) (##sys#structure? x (##sys#slot rtd 1))) ) )
62
63(define record-constructor
64  (lambda (rtd #!optional field-names)
65    (if (not (rtd? rtd))
66        (error 'record-constructor "illegal rtd argument" rtd))
67    (if (or (not field-names)
68            (equal? field-names (rtd-fields rtd)))
69        (let ((rec-length (rtd-length rtd)))
70          (lambda elts
71            (if (= (length elts) rec-length) #t
72                (error 'record-constructor
73                       "wrong number of arguments"
74                       (rtd-name rtd)))
75            (apply ##sys#make-structure (rtd-name rtd) elts)))
76        (let ((rec-length (rtd-length rtd))
77              (fields (rtd-fields rtd)) 
78              (name (rtd-name rtd)) )
79          (if (or (and (list? field-names) (has-duplicates? field-names))
80                  (not (every (lambda (x) (memq x fields))
81                              field-names)) )
82              (error
83               'record-constructor "invalid field-names argument"
84               fields))
85          (let ((field-length (length field-names))
86                (offsets
87                 (map (lambda (field) (add1 (list-index (cut eq? <> field) fields)))
88                      field-names)))
89            (lambda elts
90              (unless (= (length elts) field-length)
91                (error 'record-constructor
92                       "wrong number of arguments"
93                       (rtd-name rtd) ) )
94              (let ((result (##sys#allocate-vector (fx+ 1 rec-length) #f (void) #f)))
95                (##core#inline "C_vector_to_structure" result)
96                (##sys#setslot result 0 name)
97                (for-each (lambda (offset elt)
98                            (##sys#setslot result offset elt))
99                          offsets
100                          elts)
101                result)))))))
102
103(define record-accessor
104  (lambda (rtd field-name)
105    (if (not (rtd? rtd))
106        (error 'record-accessor "invalid rtd argument" rtd))
107    (let ((index (list-index (cut eq? field-name <>) (rtd-fields rtd)))
108          (name (rtd-name rtd)) )
109      (if (not index)
110          (error 'record-accessor "invalid field-name argument"
111                 field-name))
112      (let ((i (fx+ index 1)))
113        (lambda (x)
114          (##sys#check-structure x name '<rtd-accessor>)
115          (##sys#slot x i))))))
116
117(define record-modifier
118  (lambda (rtd field-name)
119    (if (not (rtd? rtd))
120        (error 'record-modifier "invalid rtd argument" rtd))
121    (let ((index (list-index (cut eq? field-name <>) (rtd-fields rtd)))
122          (name (rtd-name rtd)))
123      (if (not index)
124          (error 'record-modifier "invalid field-name argument"
125                 field-name))
126      (let ((i (fx+ index 1)))
127        (lambda (x y)
128          (##sys#check-structure x name '<rtd-modifier>) 
129          (##sys#setslot x i y))))))
130
131)
Note: See TracBrowser for help on using the repository browser.