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

Last change on this file since 38033 was 38033, checked in by Ivan Raikov, 2 months ago

patch port to c5

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)
31(use srfi-1)
32
33(define (rtd? x) (##sys#structure? x 'rtd))
34(define (rtd-name rtd) (##sys#slot rtd 1))
35(define (rtd-fields rtd) (##sys#slot rtd 2))
36(define (rtd-length rtd) (##sys#slot rtd 3))
37
38(define (has-duplicates? lst)
39  (cond ((null? lst) #f)
40        ((memq (car lst) (cdr lst)) #t)
41        (else (has-duplicates? (cdr lst)))))
42
43(define make-record-type
44  (lambda (type-name field-names)
45    (if (string? type-name)
46        (set! type-name (string->symbol type-name))
47        (##sys#check-symbol type-name 'make-record-type) )
48    (if (or (and (list? field-names) (has-duplicates? field-names))
49            (not (every symbol? field-names)))
50        (error 'make-record-type "illegal field-names argument"
51               field-names))
52    (##sys#make-structure
53     'rtd
54     type-name
55     field-names
56     (length field-names) ) ) )
57
58(define record-predicate
59  (lambda (rtd)
60    (if (not (rtd? rtd))
61        (error 'record-predicate "invalid argument - not a record type" rtd))
62    (lambda (x) (##sys#structure? x (##sys#slot rtd 1))) ) )
63
64(define record-constructor
65  (lambda (rtd #!optional field-names)
66    (if (not (rtd? rtd))
67        (error 'record-constructor "illegal rtd argument" rtd))
68    (if (or (not field-names)
69            (equal? field-names (rtd-fields rtd)))
70        (let ((rec-length (rtd-length rtd)))
71          (lambda elts
72            (if (= (length elts) rec-length) #t
73                (error 'record-constructor
74                       "wrong number of arguments"
75                       (rtd-name rtd)))
76            (apply ##sys#make-structure (rtd-name rtd) elts)))
77        (let ((rec-length (rtd-length rtd))
78              (fields (rtd-fields rtd)) 
79              (name (rtd-name rtd)) )
80          (if (or (and (list? field-names) (has-duplicates? field-names))
81                  (not (every (lambda (x) (memq x fields))
82                              field-names)) )
83              (error
84               'record-constructor "invalid field-names argument"
85               fields))
86          (let ((field-length (length field-names))
87                (offsets
88                 (map (lambda (field) (add1 (list-index (cut eq? <> field) fields)))
89                      field-names)))
90            (lambda elts
91              (unless (= (length elts) field-length)
92                (error 'record-constructor
93                       "wrong number of arguments"
94                       (rtd-name rtd) ) )
95              (let ((result (##sys#allocate-vector (fx+ 1 rec-length) #f (void) #f)))
96                (##core#inline "C_vector_to_structure" result)
97                (##sys#setslot result 0 name)
98                (for-each (lambda (offset elt)
99                            (##sys#setslot result offset elt))
100                          offsets
101                          elts)
102                result)))))))
103
104(define record-accessor
105  (lambda (rtd field-name)
106    (if (not (rtd? rtd))
107        (error 'record-accessor "invalid rtd argument" rtd))
108    (let ((index (list-index (cut eq? field-name <>) (rtd-fields rtd)))
109          (name (rtd-name rtd)) )
110      (if (not index)
111          (error 'record-accessor "invalid field-name argument"
112                 field-name))
113      (let ((i (fx+ index 1)))
114        (lambda (x)
115          (##sys#check-structure x name '<rtd-accessor>)
116          (##sys#slot x i))))))
117
118(define record-modifier
119  (lambda (rtd field-name)
120    (if (not (rtd? rtd))
121        (error 'record-modifier "invalid rtd argument" rtd))
122    (let ((index (list-index (cut eq? field-name <>) (rtd-fields rtd)))
123          (name (rtd-name rtd)))
124      (if (not index)
125          (error 'record-modifier "invalid field-name argument"
126                 field-name))
127      (let ((i (fx+ index 1)))
128        (lambda (x y)
129          (##sys#check-structure x name '<rtd-modifier>) 
130          (##sys#setslot x i y))))))
131
132)
Note: See TracBrowser for help on using the repository browser.