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 / tvector.scm < prev    next >
Text File  |  1999-01-02  |  4KB  |  91 lines
  1. ;;; -*-Scheme-*-
  2. ;;;
  3. ;;; $Id: tvector.scm,v 1.2 1999/01/02 06:19:10 cph Exp $
  4. ;;;
  5. ;;; Copyright (c) 1995-1999 Massachusetts Institute of Technology
  6. ;;;
  7. ;;; This program is free software; you can redistribute it and/or
  8. ;;; modify it under the terms of the GNU General Public License as
  9. ;;; published by the Free Software Foundation; either version 2 of the
  10. ;;; License, or (at your option) any later version.
  11. ;;;
  12. ;;; This program is distributed in the hope that it will be useful,
  13. ;;; but 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. ;;;; Tagged Vectors
  22.  
  23. (declare (usual-integrations))
  24.  
  25. ;;; These procedures are optimized for safety.  Applications that need
  26. ;;; speed are assumed to break this abstraction and use "%record"
  27. ;;; calls to construct and access tagged vectors.
  28.  
  29. (define (make-tagged-vector tag length)
  30.   (guarantee-dispatch-tag tag 'MAKE-TAGGED-VECTOR)
  31.   (guarantee-index-integer length 'MAKE-TAGGED-VECTOR)
  32.   (let ((result
  33.      (object-new-type (ucode-type record)
  34.               (make-vector (fix:+ length 1)
  35.                        record-slot-uninitialized))))
  36.     (%record-set! result 0 tag)
  37.     result))
  38.  
  39. (define (tagged-vector tag . elements)
  40.   (guarantee-dispatch-tag tag 'MAKE-TAGGED-VECTOR)
  41.   (object-new-type (ucode-type record) (apply vector tag elements)))
  42.  
  43. (define (tagged-vector? object)
  44.   (and (%record? object)
  45.        (dispatch-tag? (%record-ref object 0))))
  46.  
  47. (define (tagged-vector-tag vector)
  48.   (guarantee-tagged-vector vector 'TAGGED-VECTOR-TAG)
  49.   (%record-ref vector 0))
  50.  
  51. (define (set-tagged-vector-tag! vector tag)
  52.   (guarantee-tagged-vector vector 'SET-TAGGED-VECTOR-TAG!)
  53.   (guarantee-dispatch-tag tag 'SET-TAGGED-VECTOR-TAG!)
  54.   (%record-set! vector 0 tag))
  55.  
  56. (define (tagged-vector-length vector)
  57.   (guarantee-tagged-vector vector 'TAGGED-VECTOR-LENGTH)
  58.   (fix:- (%record-length vector) 1))
  59.  
  60. (define (tagged-vector-element vector index)
  61.   (guarantee-tagged-vector-ref vector index 'TAGGED-VECTOR-ELEMENT)
  62.   (%record-ref vector (fix:+ index 1)))
  63.  
  64. (define (set-tagged-vector-element! vector index value)
  65.   (guarantee-tagged-vector-ref vector index 'SET-TAGGED-VECTOR-ELEMENT!)
  66.   (%record-set! vector (fix:+ index 1) value))
  67.  
  68. (define (tagged-vector-element-initialized? vector index)
  69.   (guarantee-tagged-vector-ref vector index
  70.                    'TAGGED-VECTOR-ELEMENT-INITIALIZED?)
  71.   (not (eq? (%record-ref vector (fix:+ index 1)) record-slot-uninitialized)))
  72.  
  73. (define (guarantee-tagged-vector vector caller)
  74.   (if (not (tagged-vector? vector))
  75.       (error:wrong-type-argument vector "tagged vector" caller)))
  76.  
  77. (define (guarantee-tagged-vector-ref vector index caller)
  78.   (guarantee-tagged-vector vector caller)
  79.   (guarantee-index-integer index caller)
  80.   (if (not (fix:< index (fix:- (%record-length vector) 1)))
  81.       (error:bad-range-argument index caller)))
  82.  
  83. (define (guarantee-index-integer index caller)
  84.   (if (not (and (fix:fixnum? index) (fix:>= index 0)))
  85.       (error:wrong-type-argument vector "non-negative fixnum" caller)))
  86.  
  87. (define record-slot-uninitialized)
  88.  
  89. (define (initialize-tagged-vector!)
  90.   (set! record-slot-uninitialized (intern "#[record-slot-uninitialized]"))
  91.   unspecific)