From bd9733926076885e3417b74de76e4c9c7bc56254 Mon Sep 17 00:00:00 2001 From: Bryan Newbold Date: Mon, 20 Feb 2017 00:05:28 -0800 Subject: Import Upstream version 2c7 --- recobj.scm | 55 +++++++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 55 insertions(+) create mode 100644 recobj.scm (limited to 'recobj.scm') 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 -- cgit v1.2.3