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 | ) |
---|