home *** CD-ROM | disk | FTP | other *** search
/ MacFormat 1994 November / macformat-018.iso / Utility Spectacular / Developer / macgambit-20-compiler-src-p2 / Thomas / record.scm < prev    next >
Encoding:
Text File  |  1994-07-26  |  6.3 KB  |  169 lines  |  [TEXT/gamI]
  1. ; -*-Scheme-*-
  2. ; 
  3. ; $Id: record.scm,v 1.3 1992/09/23 15:30:30 birkholz Exp $
  4. ; $MIT-Header: /scheme/users/cph/src/runtime/RCS/record.scm,v 1.12 1991/11/26 06:50:09 cph Exp $
  5. ; 
  6. ; Copyright (c) 1989-91 Massachusetts Institute of Technology
  7. ; 
  8. ; This material was developed by the Scheme project at the Massachusetts
  9. ; Institute of Technology, Department of Electrical Engineering and
  10. ; Computer Science.  Permission to copy this software, to redistribute
  11. ; it, and to use it for any purpose is granted, subject to the following
  12. ; restrictions and understandings.
  13. ; 
  14. ; 1. Any copy made of this software must include this copyright notice
  15. ; in full.
  16. ; 
  17. ; 2. Users of this software agree to make their best efforts (a) to
  18. ; return to the MIT Scheme project any improvements or extensions that
  19. ; they make, so that these may be included in future releases; and (b)
  20. ; to inform MIT of noteworthy uses of this software.
  21. ; 
  22. ; 3. All materials developed as a consequence of the use of this
  23. ; software shall duly acknowledge such use, in accordance with the usual
  24. ; standards of acknowledging credit in academic research.
  25. ; 
  26. ; 4. MIT has made no warrantee or representation that the operation of
  27. ; this software will be error-free, and MIT is under no obligation to
  28. ; provide any services, by way of maintenance, update, or otherwise.
  29. ; 
  30. ; 5. In conjunction with products arising from the use of this material,
  31. ; there shall be no use of the name of the Massachusetts Institute of
  32. ; Technology nor of any adaptation thereof in any advertising,
  33. ; promotional, or sales literature without prior written consent from
  34. ; MIT in each case.
  35.  
  36. ; This file requires the following non-IEEE primitives:
  37.  
  38. ; error:wrong-type-argument and error:bad-range-argument each signal Scheme
  39. ; conditions indicating an argument of the wrong type or invalid value
  40. ; (respectively).
  41.  
  42. ;;;; Records
  43.  
  44. ;;; adapted from JAR's implementation
  45. ;;; conforms to R4RS proposal
  46.  
  47. (define record-type-marker
  48.   (string->symbol "#[(runtime record)record-type-marker]"))
  49.  
  50. (define (make-record-type type-name field-names)
  51.   (vector record-type-marker type-name (map (lambda (x) x) field-names)))
  52.  
  53. (define (record-type? object)
  54.   (and (vector? object)
  55.        (= (vector-length object) 3)
  56.        (eq? (vector-ref object 0) record-type-marker)))
  57.  
  58. (define (record-type-name record-type)
  59.   (if (not (record-type? record-type))
  60.       (error:wrong-type-argument record-type "record type" 'RECORD-TYPE-NAME))
  61.   (vector-ref record-type 1))
  62.  
  63. (define (record-type-field-names record-type)
  64.   (if (not (record-type? record-type))
  65.       (error:wrong-type-argument record-type "record type"
  66.                  'RECORD-TYPE-FIELD-NAMES))
  67.   (map (lambda (x) x) (vector-ref record-type 2)))
  68.  
  69. (define (record-type-record-length record-type)
  70.   (+ (length (vector-ref record-type 2)) 1))
  71.  
  72. (define (record-type-field-index record-type field-name procedure-name)
  73.   (let loop ((field-names (vector-ref record-type 2)) (index 1))
  74.     (if (null? field-names)
  75.     (error:bad-range-argument field-name procedure-name))
  76.     (if (eq? field-name (car field-names))
  77.     index
  78.     (loop (cdr field-names) (+ index 1)))))
  79.  
  80. (define (record-type-error record record-type procedure)
  81.   (error:wrong-type-argument
  82.    record
  83.    (string-append "record of type "
  84.           (let ((type-name (vector-ref record-type 1)))
  85.             (cond ((string? type-name) type-name)
  86.               ((symbol? type-name) type-name)
  87.               (else "<<unknown data type for name>>"))))
  88.    procedure))
  89.  
  90. (define (record-constructor record-type . field-names)
  91.   (if (not (record-type? record-type))
  92.       (error:wrong-type-argument record-type "record type"
  93.                  'RECORD-CONSTRUCTOR))
  94.   (let ((field-names
  95.      (if (null? field-names)
  96.          (vector-ref record-type 2)
  97.          (car field-names))))
  98.     (let ((record-length (record-type-record-length record-type))
  99.       (number-of-inits (length field-names))
  100.       (indexes
  101.        (map (lambda (field-name)
  102.           (record-type-field-index record-type
  103.                        field-name
  104.                        'RECORD-CONSTRUCTOR))
  105.         field-names)))
  106.       (lambda field-values
  107.     (if (not (= (length field-values) number-of-inits))
  108.         (error "wrong number of arguments to record constructor"
  109.            field-values record-type field-names))
  110.     (let ((record (make-vector record-length)))
  111.       (vector-set! record 0 record-type)
  112.       (for-each (lambda (index value) (vector-set! record index value))
  113.             indexes
  114.             field-values)
  115.       record)))))
  116.  
  117. (define (record? object)
  118.   (and (vector? object)
  119.        (> (vector-length object) 0)
  120.        (record-type? (vector-ref object 0))))
  121.  
  122. (define (record-type-descriptor record)
  123.   (if (not (record? record))
  124.       (error:wrong-type-argument record "record" 'RECORD-TYPE-DESCRIPTOR))
  125.   (vector-ref record 0))
  126.  
  127. (define (record-copy record)
  128.     (list->vector (vector->list record)))
  129.  
  130. (define (record-predicate record-type)
  131.   (if (not (record-type? record-type))
  132.       (error:wrong-type-argument record-type "record type" 'RECORD-PREDICATE))
  133.   (let ((record-length (record-type-record-length record-type)))
  134.     (lambda (object)
  135.       (and (vector? object)
  136.        (= (vector-length object) record-length)
  137.        (eq? (vector-ref object 0) record-type)))))
  138.  
  139. (define (record-accessor record-type field-name)
  140.   (if (not (record-type? record-type))
  141.       (error:wrong-type-argument record-type "record type" 'RECORD-ACCESSOR))
  142.   (let ((record-length (record-type-record-length record-type))
  143.     (procedure-name `(RECORD-ACCESSOR ,record-type ',field-name))
  144.     (index
  145.      (record-type-field-index record-type field-name 'RECORD-ACCESSOR)))
  146.     (lambda (record)
  147.       (if (not (and (vector? record)
  148.             (= (vector-length record) record-length)
  149.             (eq? (vector-ref record 0) record-type)))
  150.       (record-type-error record record-type procedure-name))
  151.       (vector-ref record index))))
  152.  
  153. (define (record-modifier record-type field-name)
  154.   (if (not (record-type? record-type))
  155.       (error:wrong-type-argument record-type "record type" 'RECORD-UPDATER))
  156.   (let ((record-length (record-type-record-length record-type))
  157.     (procedure-name `(RECORD-UPDATER ,record-type ',field-name))
  158.     (index
  159.      (record-type-field-index record-type field-name 'RECORD-UPDATER)))
  160.     (lambda (record field-value)
  161.       (if (not (and (vector? record)
  162.             (= (vector-length record) record-length)
  163.             (eq? (vector-ref record 0) record-type)))
  164.       (record-type-error record record-type procedure-name))
  165.       (vector-set! record index field-value))))
  166.  
  167. (define record-updater
  168.   record-modifier)
  169.