home *** CD-ROM | disk | FTP | other *** search
/ OS/2 Shareware BBS: 10 Tools / 10-Tools.zip / mitsch75.zip / scheme-7_5_17-src.zip / scheme-7.5.17 / src / runtime / record.scm < prev    next >
Text File  |  1999-01-02  |  10KB  |  286 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: record.scm,v 1.28 1999/01/02 06:11:34 cph Exp $
  4.  
  5. Copyright (c) 1989-1999 Massachusetts Institute of Technology
  6.  
  7. This program is free software; you can redistribute it and/or modify
  8. it under the terms of the GNU General Public License as published by
  9. the Free Software Foundation; either version 2 of the License, or (at
  10. your option) any later version.
  11.  
  12. This program is distributed in the hope that it will be useful, but
  13. WITHOUT ANY WARRANTY; without even the implied warranty of
  14. MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  15. General Public License for more details.
  16.  
  17. You should have received a copy of the GNU General Public License
  18. along with this program; if not, write to the Free Software
  19. Foundation, Inc., 675 Mass Ave, Cambridge, MA 02139, USA.
  20. |#
  21.  
  22. ;;;; Records
  23. ;;; package: (runtime record)
  24.  
  25. ;;; adapted from JAR's implementation
  26. ;;; conforms to R4RS proposal
  27.  
  28. (declare (usual-integrations))
  29.  
  30. (define-primitives
  31.   (%record? 1)
  32.   (%record -1)
  33.   (%record-length 1)
  34.   (%record-ref 2)
  35.   (%record-set! 3)
  36.   (primitive-object-ref 2)
  37.   (primitive-object-set! 3)
  38.   (primitive-object-set-type 2))
  39.  
  40. (define (%make-record length #!optional object)
  41.   (if (not (exact-integer? length))
  42.       (error:wrong-type-argument length "exact integer" '%MAKE-RECORD))
  43.   (if (not (> length 0))
  44.       (error:bad-range-argument length '%MAKE-RECORD))
  45.   (object-new-type
  46.    (ucode-type record)
  47.    ((ucode-primitive vector-cons) length
  48.                   (if (default-object? object) #f object))))
  49.  
  50. (define (%record-copy record)
  51.   (let ((length (%record-length record)))
  52.     (let ((result (object-new-type (ucode-type record) (make-vector length))))
  53.       ;; Clobber RESULT's length field with that of RECORD, since
  54.       ;; there is important information in the type of that field that
  55.       ;; is not preserved by %RECORD-LENGTH.
  56.       (primitive-object-set! result 0 (primitive-object-ref record 0))
  57.       (do ((index 0 (+ index 1)))
  58.       ((= index length))
  59.     (%record-set! result index (%record-ref record index)))
  60.       result)))
  61.  
  62. (define record-type-type-tag)
  63. (define unparse-record)
  64. (define record-description)
  65.  
  66. (define (initialize-record-type-type!)
  67.   (let ((type
  68.      (%record #f
  69.           "record-type"
  70.           '(RECORD-TYPE-NAME
  71.             RECORD-TYPE-FIELD-NAMES
  72.             RECORD-TYPE-DISPATCH-TAG)
  73.           #f)))
  74.     (set! record-type-type-tag (make-dispatch-tag type))
  75.     (%record-set! type 0 record-type-type-tag)
  76.     (%record-set! type 3 record-type-type-tag)))
  77.  
  78. (define (initialize-record-procedures!)
  79.   (set! unparse-record (make-generic-procedure 2 'UNPARSE-RECORD))
  80.   (set-generic-procedure-default-generator! unparse-record
  81.     (let ((record-method (standard-unparser-method 'RECORD #f)))
  82.       (lambda (generic tags)
  83.     generic
  84.     (let ((tag (cadr tags)))
  85.       (cond ((record-type? (dispatch-tag-contents tag))
  86.          (standard-unparser-method
  87.           (record-type-name (dispatch-tag-contents tag))
  88.           #f))
  89.         ((eq? tag record-type-type-tag)
  90.          (standard-unparser-method 'TYPE
  91.            (lambda (type port)
  92.              (write-char #\space port)
  93.              (display (record-type-name type) port))))
  94.         ((eq? tag (built-in-dispatch-tag 'DISPATCH-TAG))
  95.          (standard-unparser-method 'DISPATCH-TAG
  96.            (lambda (tag port)
  97.              (write-char #\space port)
  98.              (write (dispatch-tag-contents tag) port))))
  99.         (else record-method))))))
  100.   (set! set-record-type-unparser-method!
  101.     set-record-type-unparser-method!/after-boot)
  102.   (for-each (lambda (t.m)
  103.           (set-record-type-unparser-method! (car t.m) (cdr t.m)))
  104.         deferred-unparser-methods)
  105.   (set! deferred-unparser-methods)
  106.   (set! record-description (make-generic-procedure 1 'RECORD-DESCRIPTION))
  107.   (set-generic-procedure-default-generator! record-description
  108.     (lambda (generic tags)
  109.       generic
  110.       (if (record-type? (dispatch-tag-contents (car tags)))
  111.       (lambda (record)
  112.         (let ((type (record-type-descriptor record)))
  113.           (map (lambda (field-name)
  114.              `(,field-name
  115.                ,((record-accessor type field-name) record)))
  116.            (record-type-field-names type))))
  117.       (lambda (record)
  118.         (let loop ((i (fix:- (%record-length record) 1)) (d '()))
  119.           (if (fix:< i 0)
  120.           d
  121.           (loop (fix:- i 1)
  122.             (cons (list i (%record-ref record i)) d)))))))))
  123.  
  124. (define (make-record-type type-name field-names #!optional print-method)
  125.   (guarantee-list-of-unique-symbols field-names 'MAKE-RECORD-TYPE)
  126.   (let ((record-type
  127.      (%record record-type-type-tag
  128.           (->string type-name)
  129.           (list-copy field-names)
  130.           #f)))
  131.     (%record-set! record-type 3 (make-dispatch-tag record-type))
  132.     (if (not (default-object? print-method))
  133.     (set-record-type-unparser-method! record-type print-method))
  134.     record-type))
  135.  
  136. (define (record-type? object)
  137.   (and (%record? object)
  138.        (eq? (%record-ref object 0) record-type-type-tag)))
  139.  
  140. (define (record-type-name record-type)
  141.   (guarantee-record-type record-type 'RECORD-TYPE-NAME)
  142.   (%record-ref record-type 1))
  143.  
  144. (define (record-type-field-names record-type)
  145.   (guarantee-record-type record-type 'RECORD-TYPE-FIELD-NAMES)
  146.   (%record-ref record-type 2))
  147.  
  148. (define (record-type-dispatch-tag record-type)
  149.   (guarantee-record-type record-type 'RECORD-TYPE-DISPATCH-TAG)
  150.   (%record-ref record-type 3))
  151.  
  152. (define (set-record-type-unparser-method! record-type method)
  153.   (set! deferred-unparser-methods
  154.     (cons (cons record-type method) deferred-unparser-methods))
  155.   unspecific)
  156.  
  157. (define deferred-unparser-methods '())
  158.  
  159. (define (set-record-type-unparser-method!/after-boot record-type method)
  160.   (if (not (or (not method) (procedure? method)))
  161.       (error:wrong-type-argument method "unparser method"
  162.                  'SET-RECORD-TYPE-UNPARSER-METHOD!))
  163.   (let ((tag (record-type-dispatch-tag record-type)))
  164.     (remove-generic-procedure-generators unparse-record
  165.                      (list (make-dispatch-tag #f) tag))
  166.     (add-generic-procedure-generator unparse-record
  167.       (lambda (generic tags)
  168.     generic
  169.     (and (eq? (cadr tags) tag) method)))))
  170.  
  171. (define (record-constructor record-type #!optional field-names)
  172.   (guarantee-record-type record-type 'RECORD-CONSTRUCTOR)
  173.   (let ((all-field-names (record-type-field-names record-type))
  174.     (tag (record-type-dispatch-tag record-type)))
  175.     (let ((field-names
  176.        (if (default-object? field-names) all-field-names field-names))
  177.       (record-length (+ 1 (length all-field-names))))
  178.       (let ((number-of-inits (length field-names))
  179.         (indexes
  180.          (map (lambda (field-name)
  181.             (record-type-field-index record-type
  182.                          field-name
  183.                          'RECORD-CONSTRUCTOR))
  184.           field-names)))
  185.     (lambda field-values
  186.       (if (not (= (length field-values) number-of-inits))
  187.           (error "wrong number of arguments to record constructor"
  188.              field-values record-type field-names))
  189.       (let ((record
  190.          (object-new-type (ucode-type record)
  191.                   (make-vector record-length))))
  192.         (%record-set! record 0 tag)
  193.         (do ((indexes indexes (cdr indexes))
  194.          (field-values field-values (cdr field-values)))
  195.         ((null? indexes))
  196.           (%record-set! record (car indexes) (car field-values)))
  197.         record))))))
  198.  
  199. (define (record? object)
  200.   (and (%record? object)
  201.        (dispatch-tag? (%record-ref object 0))
  202.        (record-type? (dispatch-tag-contents (%record-ref object 0)))))
  203.  
  204. (define (record-type-descriptor record)
  205.   (guarantee-record record 'RECORD-TYPE-DESCRIPTOR)
  206.   (dispatch-tag-contents (%record-ref record 0)))
  207.  
  208. (define (record-copy record)
  209.   (guarantee-record record 'RECORD-COPY)
  210.   (%record-copy record))
  211.  
  212. (define (record-predicate record-type)
  213.   (guarantee-record-type record-type 'RECORD-PREDICATE)
  214.   (let ((tag (record-type-dispatch-tag record-type)))
  215.     (lambda (object)
  216.       (and (%record? object)
  217.        (eq? (%record-ref object 0) tag)))))
  218.  
  219. (define (record-accessor record-type field-name)
  220.   (guarantee-record-type record-type 'RECORD-ACCESSOR)
  221.   (let ((tag (record-type-dispatch-tag record-type))
  222.     (type-name (record-type-name record-type))
  223.     (procedure-name `(RECORD-ACCESSOR ,record-type ',field-name))
  224.     (index
  225.      (record-type-field-index record-type field-name 'RECORD-ACCESSOR)))
  226.     (lambda (record)
  227.       (guarantee-record-of-type record tag type-name procedure-name)
  228.       (%record-ref record index))))
  229.  
  230. (define (record-modifier record-type field-name)
  231.   (guarantee-record-type record-type 'RECORD-MODIFIER)
  232.   (let ((tag (record-type-dispatch-tag record-type))
  233.     (type-name (record-type-name record-type))
  234.     (procedure-name `(RECORD-ACCESSOR ,record-type ',field-name))
  235.     (index
  236.      (record-type-field-index record-type field-name 'RECORD-MODIFIER)))
  237.     (lambda (record field-value)
  238.       (guarantee-record-of-type record tag type-name procedure-name)
  239.       (%record-set! record index field-value))))
  240.  
  241. (define record-updater
  242.   record-modifier)
  243.  
  244. (define (record-type-field-index record-type field-name error?)
  245.   (let loop ((field-names (record-type-field-names record-type)) (index 1))
  246.     (cond ((null? field-names)
  247.        (and error?
  248.         (record-type-field-index
  249.          record-type
  250.          (error:no-such-slot record-type field-name)
  251.          error?)))
  252.       ((eq? field-name (car field-names)) index)
  253.       (else (loop (cdr field-names) (+ index 1))))))
  254.  
  255. (define (->string object)
  256.   (if (string? object)
  257.       object
  258.       (write-to-string object)))
  259.  
  260. (define-integrable (guarantee-list-of-unique-symbols object procedure)
  261.   (if (not (list-of-unique-symbols? object))
  262.       (error:wrong-type-argument object "list of unique symbols" procedure)))
  263.  
  264. (define (list-of-unique-symbols? object)
  265.   (and (list? object)
  266.        (let loop ((elements object))
  267.      (or (null? elements)
  268.          (and (symbol? (car elements))
  269.           (not (memq (car elements) (cdr elements)))
  270.           (loop (cdr elements)))))))
  271.  
  272. (define-integrable (guarantee-record-type record-type procedure)
  273.   (if (not (record-type? record-type))
  274.       (error:wrong-type-argument record-type "record type" procedure)))
  275.  
  276. (define-integrable (guarantee-record-of-type record tag type-name
  277.                          procedure-name)
  278.   (if (not (and (%record? record)
  279.         (eq? (%record-ref record 0) tag)))
  280.       (error:wrong-type-argument record
  281.                  (string-append "record of type " type-name)
  282.                  procedure-name)))
  283.  
  284. (define-integrable (guarantee-record record procedure-name)
  285.   (if (not (record? record))
  286.       (error:wrong-type-argument record "record" procedure-name)))