#| -*-Scheme-*-

$Id: valclass.scm,v 1.9 2003/02/14 18:28:08 cph Exp $

Copyright 1989,1990,1999,2001,2002,2003 Massachusetts Institute of Technology

This file is part of MIT/GNU Scheme.

MIT/GNU Scheme is free software; you can redistribute it and/or modify
it under the terms of the GNU General Public License as published by
the Free Software Foundation; either version 2 of the License, or (at
your option) any later version.

MIT/GNU Scheme is distributed in the hope that it will be useful, but
WITHOUT ANY WARRANTY; without even the implied warranty of
MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
General Public License for more details.

You should have received a copy of the GNU General Public License
along with MIT/GNU Scheme; if not, write to the Free Software
Foundation, Inc., 59 Temple Place - Suite 330, Boston, MA 02111-1307,
USA.

|#

;;;; RTL Value Classes

(declare (usual-integrations))

(define-structure (value-class
		   (conc-name value-class/)
		   (constructor %make-value-class (name parent))
		   (print-procedure
		    (unparser/standard-method 'VALUE-CLASS
		      (lambda (state class)
			(unparse-object state (value-class/name class))))))
  (name false read-only true)
  (parent false read-only true)
  (children '())
  (properties (make-1d-table) read-only true))

(define (make-value-class name parent)
  (let ((class (%make-value-class name parent)))
    (if parent
	(set-value-class/children!
	 parent
	 (cons class (value-class/children parent))))
    class))

(define (value-class/ancestor-or-self? class ancestor)
  (or (eq? class ancestor)
      (let loop ((class (value-class/parent class)))
	(and class
	     (or (eq? class ancestor)
		 (loop (value-class/parent class)))))))

(define (value-class/ancestry class)
  (value-class/partial-ancestry class value-class=value))

(define (value-class/partial-ancestry class ancestor)
  (let loop ((class* class) (ancestry '()))
    (if (not class*)
	(error "value-class not an ancestor" class ancestor))
    (let ((ancestry (cons class* ancestry)))
      (if (eq? class* ancestor)
	  ancestry
	  (loop (value-class/parent class*) ancestry)))))

(define (value-class/nearest-common-ancestor x y)
  (let loop
      ((join false)
       (x (value-class/ancestry x))
       (y (value-class/ancestry y)))
    (if (and (not (null? x))
	     (not (null? y))
	     (eq? (car x) (car y)))
	(loop (car x) (cdr x) (cdr y))
	join)))

(define-syntax define-value-class
  (sc-macro-transformer
   (lambda (form environment)
     (let ((name (cadr form))
	   (parent-name (caddr form)))
       (let* ((name->variable
	       (lambda (name)
		 (symbol-append 'VALUE-CLASS= name)))
	      (variable (name->variable name)))
	 `(BEGIN
	    (DEFINE ,variable
	      (MAKE-VALUE-CLASS
	       ',name
	       ,(if parent-name
		    (close-syntax (name->variable parent-name)
				  environment)
		    `#F)))
	    (DEFINE (,(symbol-append variable '?) CLASS)
	      (VALUE-CLASS/ANCESTOR-OR-SELF? CLASS ,variable))
	    (DEFINE (,(symbol-append 'REGISTER- variable '?) REGISTER)
	      (VALUE-CLASS/ANCESTOR-OR-SELF?
	       (REGISTER-VALUE-CLASS REGISTER)
	       ,variable))))))))

(define-value-class value #f)
(define-value-class float value)
(define-value-class word value)
(define-value-class object word)
(define-value-class unboxed word)
(define-value-class address unboxed)
(define-value-class immediate unboxed)
(define-value-class ascii immediate)
(define-value-class datum immediate)
(define-value-class fixnum immediate)
(define-value-class type immediate)