diff options
Diffstat (limited to 'record.scm')
| -rw-r--r-- | record.scm | 211 |
1 files changed, 211 insertions, 0 deletions
diff --git a/record.scm b/record.scm new file mode 100644 index 0000000..555d3ea --- /dev/null +++ b/record.scm @@ -0,0 +1,211 @@ +; "record.scm" record data types +; Written by David Carlton, carlton@husc.harvard.edu. +; Re-Written by Aubrey Jaffer, jaffer@ai.mit.edu +; +; This code is in the public domain. + +; Implements `record' data structures for Scheme. Using only the +; opacity of procedures, makes record datatypes and +; record-type-descriptors disjoint from R4RS types and each other, and +; prevents forgery and corruption (modification without using +; RECORD-MODIFIER) of records. + +(require 'common-list-functions) + +(define vector? vector?) +(define vector-ref vector-ref) +(define vector-set! vector-set!) +(define vector-fill! vector-fill!) +(define vector->list vector->list) + +(define record-modifier #f) +(define record-accessor #f) +(define record-constructor #f) +(define record-predicate #f) +(define make-record-type #f) + +(let (;; Need to close these to keep magic-cookie hidden. + (make-vector make-vector) + (vector vector) + + ;; We have to wrap these to keep magic-cookie hidden. + (vect? vector?) + (vect-ref vector-ref) + (vect->list vector->list) + + ;; Need to wrap these to protect record data from being corrupted. + (vect-set! vector-set!) + (vect-fill! vector-fill!) + + (nvt "of non-vector type") + ) + (letrec + (;; Tag to identify rtd's. (A record is identified by the rtd + ;; that begins it.) + (magic-cookie (cons 'rtd '())) + (rtd? (lambda (object) + (and (vect? object) + (not (= (vector-length object) 0)) + (eq? (rtd-tag object) magic-cookie)))) + (rec? (lambda (obj) + (and (vect? obj) + (>= (vector-length obj) 1) + (or (eq? magic-cookie (rec-rtd obj)) + (rtd? (rec-rtd obj)))))) + + (vec:error + (lambda (proc-name msg obj) + (slib:error proc-name msg + (cond ((rtd? obj) 'rtd) + ((rec? obj) (rtd-name (rec-rtd obj))) + (else obj))))) + + ;; Internal accessor functions. No error checking. + (rtd-tag (lambda (x) (vect-ref x 0))) + (rtd-name (lambda (rtd) (vect-ref rtd 1))) + (rtd-fields (lambda (rtd) (vect-ref rtd 3))) + ;; rtd-vfields is padded out to the length of the vector, which is 1 + ;; more than the number of fields + (rtd-vfields (lambda (rtd) (cons #f (rtd-fields rtd)))) + ;; rtd-length is the length of the vector. + (rtd-length (lambda (rtd) (vect-ref rtd 4))) + + (rec-rtd (lambda (x) (vect-ref x 0))) + + (make-rec-type + (lambda (type-name field-names) + (if (not (string? type-name)) + (slib:error 'make-record-type "non-string type-name argument." + type-name)) + (if (or (and (list? field-names) (comlist:has-duplicates? field-names)) + (comlist:notevery symbol? field-names)) + (slib:error 'make-record-type "illegal field-names argument." + field-names)) + (let* ((augmented-length (+ 1 (length field-names))) + (rtd (vector magic-cookie + type-name + '() + field-names + augmented-length + #f + #f))) + (vect-set! rtd 5 + (lambda (x) + (and (vect? x) + (= (vector-length x) augmented-length) + (eq? (rec-rtd x) rtd)))) + (vect-set! rtd 6 + (lambda (x) + (and (vect? x) + (>= (vector-length x) augmented-length) + (eq? (rec-rtd x) rtd) + #t))) + rtd))) + + (rec-predicate + (lambda (rtd) + (if (not (rtd? rtd)) + (slib:error 'record-predicate "invalid argument." rtd)) + (vect-ref rtd 5))) + + (rec-constructor + (lambda (rtd . field-names) + (if (not (rtd? rtd)) + (slib:error 'record-constructor "illegal rtd argument." rtd)) + (if (or (null? field-names) + (equal? field-names (rtd-fields rtd))) + (let ((rec-length (- (rtd-length rtd) 1))) + (lambda elts + (if (= (length elts) rec-length) #t + (slib:error 'record-constructor + (rtd-name rtd) + "wrong number of arguments.")) + (apply vector rtd elts))) + (let ((rec-vfields (rtd-vfields rtd)) + (corrected-rec-length (rtd-length rtd)) + (field-names (car field-names))) + (if (or (and (list? field-names) (comlist:has-duplicates? field-names)) + (comlist:notevery (lambda (x) (memq x rec-vfields)) + field-names)) + (slib:error + 'record-constructor "invalid field-names argument." + (cdr rec-vfields))) + (let ((field-length (length field-names)) + (offsets + (map (lambda (field) (comlist:position field rec-vfields)) + field-names))) + (lambda elts + (if (= (length elts) field-length) #t + (slib:error 'record-constructor + (rtd-name rtd) + "wrong number of arguments.")) + (let ((result (make-vector corrected-rec-length))) + (vect-set! result 0 rtd) + (for-each (lambda (offset elt) + (vect-set! result offset elt)) + offsets + elts) + result))))))) + + (rec-accessor + (lambda (rtd field-name) + (if (not (rtd? rtd)) + (slib:error 'record-accessor "invalid rtd argument." rtd)) + (let ((index (comlist:position field-name (rtd-vfields rtd))) + (augmented-length (rtd-length rtd))) + (if (not index) + (slib:error 'record-accessor "invalid field-name argument." + field-name)) + (lambda (x) + (if (and (vect? x) + (>= (vector-length x) augmented-length) + (eq? rtd (rec-rtd x))) + #t + (slib:error 'record-accessor "wrong record type." x "not" rtd)) + (vect-ref x index))))) + + (rec-modifier + (lambda (rtd field-name) + (if (not (rtd? rtd)) + (slib:error 'record-modifier "invalid rtd argument." rtd)) + (let ((index (comlist:position field-name (rtd-vfields rtd))) + (augmented-length (rtd-length rtd))) + (if (not index) + (slib:error 'record-modifier "invalid field-name argument." + field-name)) + (lambda (x y) + (if (and (vect? x) + (>= (vector-length x) augmented-length) + (eq? rtd (rec-rtd x))) + #t + (slib:error 'record-modifier "wrong record type." x "not" rtd)) + (vect-set! x index y))))) + ) + + (set! vector? (lambda (obj) (and (not (rec? obj)) (vector? obj)))) + (set! vector-ref + (lambda (vector k) + (cond ((rec? vector) + (vec:error 'vector-ref nvt vector)) + (else (vect-ref vector k))))) + (set! vector->list + (lambda (vector k) + (cond ((rec? vector) + (vec:error 'vector->list nvt vector)) + (else (vect->list vector k))))) + (set! vector-set! + (lambda (vector k obj) + (cond ((rec? vector) + (vec:error 'vector-set! nvt vector)) + (else (vect-set! vector k obj))))) + (set! vector-fill! + (lambda (vector fill) + (cond ((rec? vector) + (vec:error 'vector-fill! nvt vector)) + (else (vect-fill! vector fill))))) + (set! record-modifier rec-modifier) + (set! record-accessor rec-accessor) + (set! record-constructor rec-constructor) + (set! record-predicate rec-predicate) + (set! make-record-type make-rec-type) + )) |