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 / compiler / base / enumer.scm < prev    next >
Text File  |  1999-01-02  |  4KB  |  107 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: enumer.scm,v 4.4 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1988, 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. ;;;; Support for enumerations
  23.  
  24. (declare (usual-integrations))
  25.  
  26. ;;;; Enumerations
  27.  
  28. (define-structure (enumeration
  29.            (conc-name enumeration/)
  30.            (constructor %make-enumeration))
  31.   (enumerands false read-only true))
  32.  
  33. (define-structure (enumerand
  34.            (conc-name enumerand/)
  35.            (print-procedure
  36.             (standard-unparser (symbol->string 'ENUMERAND)
  37.               (lambda (state enumerand)
  38.             (unparse-object state (enumerand/name enumerand))))))
  39.   (enumeration false read-only true)
  40.   (name false read-only true)
  41.   (index false read-only true))
  42.  
  43. (define (make-enumeration names)
  44.   (let ((enumerands (make-vector (length names))))
  45.     (let ((enumeration (%make-enumeration enumerands)))
  46.       (let loop ((names names) (index 0))
  47.     (if (not (null? names))
  48.         (begin
  49.           (vector-set! enumerands
  50.                index
  51.                (make-enumerand enumeration (car names) index))
  52.           (loop (cdr names) (1+ index)))))
  53.       enumeration)))
  54.  
  55. (define-integrable (enumeration/cardinality enumeration)
  56.   (vector-length (enumeration/enumerands enumeration)))
  57.  
  58. (define-integrable (enumeration/index->enumerand enumeration index)
  59.   (vector-ref (enumeration/enumerands enumeration) index))
  60.  
  61. (define-integrable (enumeration/index->name enumeration index)
  62.   (enumerand/name (enumeration/index->enumerand enumeration index)))
  63.  
  64. (define (enumeration/name->enumerand enumeration name)
  65.   (let ((end (enumeration/cardinality enumeration)))
  66.     (let loop ((index 0))
  67.       (if (< index end)
  68.       (let ((enumerand (enumeration/index->enumerand enumeration index)))
  69.         (if (eqv? (enumerand/name enumerand) name)
  70.         enumerand
  71.         (loop (1+ index))))
  72.       (error "Unknown enumeration name" name)))))
  73.  
  74. (define-integrable (enumeration/name->index enumeration name)
  75.   (enumerand/index (enumeration/name->enumerand enumeration name)))
  76.  
  77. ;;;; Method Tables
  78.  
  79. (define-structure (method-table (constructor %make-method-table))
  80.   (enumeration false read-only true)
  81.   (vector false read-only true))
  82.  
  83. (define (make-method-table enumeration default-method . method-alist)
  84.   (let ((table
  85.      (%make-method-table enumeration
  86.                  (make-vector (enumeration/cardinality enumeration)
  87.                       default-method))))
  88.     (for-each (lambda (entry)
  89.         (define-method-table-entry table (car entry) (cdr entry)))
  90.           method-alist)
  91.     table))
  92.  
  93. (define (define-method-table-entry name method-table method)
  94.   (vector-set! (method-table-vector method-table)
  95.            (enumeration/name->index (method-table-enumeration method-table)
  96.                     name)
  97.            method)
  98.   name)
  99.  
  100. (define (define-method-table-entries names method-table method)
  101.   (for-each (lambda (name)
  102.           (define-method-table-entry name method-table method))
  103.         names)
  104.   names)
  105.  
  106. (define-integrable (method-table-lookup method-table index)
  107.   (vector-ref (method-table-vector method-table) index))