Import Upstream version 2c7upstream/2c7

1 files changed, 55 insertions, 0 deletions

diff --git a/recobj.scm b/recobj.scm
new file mode 100644
index 0000000..36ab6d2
--- /dev/null
+++ b/recobj.scm
@@ -0,0 +1,55 @@
+;;; "recobj.scm" Records implemented as objects.
+;;;From: whumeniu@datap.ca (Wade Humeniuk)
+
+(require 'object)
+(require 'common-list-functions)
+
+(define record-type-name (make-generic-method))
+(define record-accessor (make-generic-method))
+(define record-modifier (make-generic-method))
+(define record? (make-generic-predicate))
+(define record-constructor (make-generic-method))
+
+(define (make-record-type type-name field-names)
+  (define self (make-object))
+
+  (make-method! self record-type-name
+		(lambda (self)
+		  type-name))
+  (make-method! self record-accessor
+		(lambda (self field-name)
+		  (let ((index (comlist:position field-name field-names)))
+		    (if (not index)
+			(slib:error "record-accessor: invalid field-name argument."
+				    field-name))
+		    (lambda (obj)
+		      (record-accessor obj index)))))
+
+  (make-method! self record-modifier
+		(lambda (self field-name)
+		  (let ((index (comlist:position field-name field-names)))
+		    (if (not index)
+			(slib:error "record-accessor: invalid field-name argument."
+				    field-name))
+		    (lambda (obj newval)
+		      (record-modifier obj index newval)))))
+
+  (make-method! self record? (lambda (self) #t))
+
+  (make-method! self record-constructor
+		(lambda (class . field-values)
+		  (let ((values (apply vector field-values)))
+		    (define self (make-object))
+		    (make-method! self record-accessor
+				  (lambda (self index)
+				    (vector-ref values index)))
+		    (make-method! self record-modifier
+				  (lambda (self index newval)
+				    (vector-set! values index newval)))
+		    (make-method! self record-type-name
+				  (lambda (self) (record-type-name class)))
+		    self)))
+  self)
+
+(provide 'record-object)
+(provide 'record)
\ No newline at end of file