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 / rtlbase / valclass.scm < prev   
Text File  |  1999-01-02  |  3KB  |  107 lines
  1. #| -*-Scheme-*-
  2.  
  3. $Id: valclass.scm,v 1.3 1999/01/02 06:06:43 cph Exp $
  4.  
  5. Copyright (c) 1989, 1990, 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. ;;;; RTL Value Classes
  23.  
  24. (declare (usual-integrations))
  25.  
  26. (define-structure (value-class
  27.            (conc-name value-class/)
  28.            (constructor %make-value-class (name parent))
  29.            (print-procedure
  30.             (unparser/standard-method 'VALUE-CLASS
  31.               (lambda (state class)
  32.             (unparse-object state (value-class/name class))))))
  33.   (name false read-only true)
  34.   (parent false read-only true)
  35.   (children '())
  36.   (properties (make-1d-table) read-only true))
  37.  
  38. (define (make-value-class name parent)
  39.   (let ((class (%make-value-class name parent)))
  40.     (if parent
  41.     (set-value-class/children!
  42.      parent
  43.      (cons class (value-class/children parent))))
  44.     class))
  45.  
  46. (define (value-class/ancestor-or-self? class ancestor)
  47.   (or (eq? class ancestor)
  48.       (let loop ((class (value-class/parent class)))
  49.     (and class
  50.          (or (eq? class ancestor)
  51.          (loop (value-class/parent class)))))))
  52.  
  53. (define (value-class/ancestry class)
  54.   (value-class/partial-ancestry class value-class=value))
  55.  
  56. (define (value-class/partial-ancestry class ancestor)
  57.   (let loop ((class* class) (ancestry '()))
  58.     (if (not class*)
  59.     (error "value-class not an ancestor" class ancestor))
  60.     (let ((ancestry (cons class* ancestry)))
  61.       (if (eq? class* ancestor)
  62.       ancestry
  63.       (loop (value-class/parent class*) ancestry)))))
  64.  
  65. (define (value-class/nearest-common-ancestor x y)
  66.   (let loop
  67.       ((join false)
  68.        (x (value-class/ancestry x))
  69.        (y (value-class/ancestry y)))
  70.     (if (and (not (null? x))
  71.          (not (null? y))
  72.          (eq? (car x) (car y)))
  73.     (loop (car x) (cdr x) (cdr y))
  74.     join)))
  75.  
  76. (let-syntax
  77.     ((define-value-class
  78.        (lambda (name parent-name)
  79.      (let* ((name->variable
  80.          (lambda (name) (symbol-append 'VALUE-CLASS= name)))
  81.         (variable (name->variable name)))
  82.        `(BEGIN
  83.           (DEFINE ,variable
  84.         (MAKE-VALUE-CLASS ',name
  85.                   ,(if parent-name
  86.                        (name->variable parent-name)
  87.                        `#F)))
  88.           (DEFINE (,(symbol-append variable '?) CLASS)
  89.         (VALUE-CLASS/ANCESTOR-OR-SELF? CLASS ,variable))
  90.           (DEFINE
  91.         (,(symbol-append 'REGISTER- variable '?) REGISTER)
  92.         (VALUE-CLASS/ANCESTOR-OR-SELF? (REGISTER-VALUE-CLASS REGISTER)
  93.                            ,variable)))))))
  94.  
  95. (define-value-class value #f)
  96. (define-value-class float value)
  97. (define-value-class word value)
  98. (define-value-class object word)
  99. (define-value-class unboxed word)
  100. (define-value-class address unboxed)
  101. (define-value-class immediate unboxed)
  102. (define-value-class ascii immediate)
  103. (define-value-class datum immediate)
  104. (define-value-class fixnum immediate)
  105. (define-value-class type immediate)
  106.  
  107. )