home *** CD-ROM | disk | FTP | other *** search
/ Dream 44 / Amiga_Dream_44.iso / RiscPc / programmation / scm4e2.arc / !Scm / slib / recobj < prev    next >
Text File  |  1994-03-31  |  2KB  |  54 lines
  1. ;;; "recobj.scm" Records implemented as objects.
  2. ;;;From: whumeniu@datap.ca (Wade Humeniuk)
  3.  
  4. (require 'object)
  5.  
  6. (define record-type-name (make-generic-method))
  7. (define record-accessor (make-generic-method))
  8. (define record-modifier (make-generic-method))
  9. (define record? (make-generic-predicate))
  10. (define record-constructor (make-generic-method))
  11.  
  12. (define (make-record-type type-name field-names)
  13.   (define self (make-object))
  14.  
  15.   (make-method! self record-type-name
  16.         (lambda (self)
  17.           type-name))
  18.   (make-method! self record-accessor
  19.         (lambda (self field-name)
  20.           (let ((index (comlist:position field-name field-names)))
  21.             (if (not index)
  22.             (slib:error "record-accessor: invalid field-name argument."
  23.                     field-name))
  24.             (lambda (obj)
  25.               (record-accessor obj index)))))
  26.  
  27.   (make-method! self record-modifier
  28.         (lambda (self field)
  29.           (let ((index (comlist:position field field-names)))
  30.             (if (not index)
  31.             (slib:error "record-accessor: invalid field-name argument."
  32.                     field-name))
  33.             (lambda (obj newval)
  34.               (record-modifier obj index newval)))))
  35.   
  36.   (make-method! self record? (lambda (self) #t))
  37.  
  38.   (make-method! self record-constructor
  39.           (lambda (class . field-values)
  40.             (let ((values (apply vector field-values)))
  41.               (define self (make-object))
  42.               (make-method! self record-accessor
  43.                     (lambda (self index)
  44.                       (vector-ref values index)))
  45.               (make-method! self record-modifier
  46.                     (lambda (self index newval)
  47.                       (vector-set! values index newval)))
  48.               (make-method! self record-type-name
  49.                     (lambda (self) (record-type-name class)))
  50.               self)))
  51.   self)
  52.  
  53. (provide 'record-object)
  54. (provide 'record)