summaryrefslogtreecommitdiffstats
path: root/record.scm
diff options
context:
space:
mode:
Diffstat (limited to 'record.scm')
-rw-r--r--record.scm211
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)
+ ))