Import Upstream version 2a6upstream/2a6

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