diff options
author | Bryan Newbold <bnewbold@robocracy.org> | 2017-02-20 00:05:25 -0800 |
---|---|---|
committer | Bryan Newbold <bnewbold@robocracy.org> | 2017-02-20 00:05:25 -0800 |
commit | 8ffbc2df0fde83082610149d24e594c1cd879f4a (patch) | |
tree | a2be9aad5101c5e450ad141d15c514bc9c2a2963 /recobj.scm | |
download | slib-8ffbc2df0fde83082610149d24e594c1cd879f4a.tar.gz slib-8ffbc2df0fde83082610149d24e594c1cd879f4a.zip |
Import Upstream version 2a6upstream/2a6
Diffstat (limited to 'recobj.scm')
-rw-r--r-- | recobj.scm | 54 |
1 files changed, 54 insertions, 0 deletions
diff --git a/recobj.scm b/recobj.scm new file mode 100644 index 0000000..caf55a6 --- /dev/null +++ b/recobj.scm @@ -0,0 +1,54 @@ +;;; "recobj.scm" Records implemented as objects. +;;;From: whumeniu@datap.ca (Wade Humeniuk) + +(require 'object) + +(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) + (let ((index (comlist:position field 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 |