;;;;  -*- Mode: Lisp; Syntax: Common-Lisp; Package: C -*-
;;;;
;;;;  Copyright (c) 1984, Taiichi Yuasa and Masami Hagiya.
;;;;  Copyright (c) 1990, Giuseppe Attardi.
;;;;  Copyright (c) 2011, Jean-Claude Beaudoin.
;;;;
;;;;    This program is free software; you can redistribute it and/or
;;;;    modify it under the terms of the GNU Lesser General Public
;;;;    License as published by the Free Software Foundation; either
;;;;    version 3 of the License, or (at your option) any later version.
;;;;
;;;;    See file '../../Copyright' for full details.

;;;; CMPTYPE  Type information.

(in-package "COMPILER")

;;; CL-TYPE is any valid type specification of Common Lisp.
;;;
;;; TYPE is a representation type used by MKCL.  TYPE is one of:
;;;
;;;				T(BOOLEAN)
;;;
;;;	FIXNUM  CHARACTER  SINGLE-FLOAT  DOUBLE-FLOAT
;;;	(VECTOR T)  STRING  BIT-VECTOR  (VECTOR FIXNUM)
;;;	(VECTOR SINGLE-FLOAT)  (VECTOR DOUBLE-FLOAT)
;;;	(ARRAY T)  (ARRAY BASE-CHAR)  (ARRAY BIT)
;;;	(ARRAY FIXNUM)
;;;	(ARRAY SINGLE-FLOAT)  (ARRAY DOUBLE-FLOAT)
;;;	STANDARD-OBJECT STRUCTURE-OBJECT
;;;	SYMBOL
;;;	UNKNOWN
;;;
;;;				NIL
;;;
;;;
;;; immediate-type:
;;;	FIXNUM		int
;;;	CHARACTER	char
;;;	SINGLE-FLOAT	float
;;;	DOUBLE-FLOAT	double

(defun member-type (type disjoint-supertypes)
  (member type disjoint-supertypes :test #'subtypep))

;;; Check if THING is an object of the type TYPE.
;;; Depends on the implementation of TYPE-OF.
;;; (only used for saving constants?)
;; (defun object-type (thing)
;;   (let ((type (if thing (type-of thing) 'SYMBOL)))
;;     (case type
;;       ((FIXNUM SHORT-FLOAT SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT SYMBOL NULL CONS) type)
;;       ((BASE-CHAR STANDARD-CHAR CHARACTER EXTENDED-CHAR) 'CHARACTER)
;;       ((STRING BASE-STRING BIT-VECTOR) type)
;;       (VECTOR (list 'VECTOR (array-element-type thing)))
;;       (ARRAY (list 'ARRAY (array-element-type thing)))
;;       (STANDARD-OBJECT 'STANDARD-OBJECT)
;;       (STRUCTURE-OBJECT 'STRUCTURE-OBJECT)
;;       (t t))))

(defun object-type (thing)
  (let ((type (if thing (type-of thing) 'SYMBOL)))
    (typecase thing
      (FIXNUM 'FIXNUM)
      ((or SHORT-FLOAT SINGLE-FLOAT DOUBLE-FLOAT LONG-FLOAT RATIO COMPLEX SYMBOL NULL CONS) type)
      ((or STANDARD-CHAR BASE-CHAR #+unicode EXTENDED-CHAR CHARACTER) type)
      (SIMPLE-BASE-STRING 'SIMPLE-BASE-STRING) (SIMPLE-STRING 'SIMPLE-STRING)
      (BASE-STRING 'BASE-STRING) (STRING 'STRING)
      (SIMPLE-BIT-VECTOR 'SIMPLE-BIT-VECTOR)
      (BIT-VECTOR 'BIT-VECTOR)
      (SIMPLE-VECTOR 'SIMPLE-VECTOR)
      (VECTOR (list 'VECTOR (array-element-type thing)))
      (SIMPLE-ARRAY (list 'SIMPLE-ARRAY (array-element-type thing)))
      (ARRAY (list 'ARRAY (array-element-type thing)))
      (STANDARD-OBJECT 'STANDARD-OBJECT)
      (STRUCTURE-OBJECT 'STRUCTURE-OBJECT)
      (t t))))




(defun known-type-p (type)
  (subtypep type 'T))

(defun type-and (t1 t2)
  ;; FIXME! Should we allow "*" as type name???
  (when (or (eq t1 t2) (eq t2 '*))
    (return-from type-and t1))
  (when (eq t1 '*)
    (return-from type-and t2))
  (let* ((si::*highest-type-tag* si::*highest-type-tag*)
	 (si::*save-types-database* t)
	 (si::*member-types* si::*member-types*)
	 (si::*elementary-types* si::*elementary-types*)
	 (tag1 (si::safe-canonical-type t1))
	 (tag2 (si::safe-canonical-type t2)))
    (cond ((and (numberp tag1) (numberp tag2))
	   (setf tag1 (si::safe-canonical-type t1)
		 tag2 (si::safe-canonical-type t2))
	   (cond ((zerop (logand tag1 tag2)) ; '(AND t1 t2) = NIL
		  NIL)
		 ((zerop (logandc2 tag1 tag2)) ; t1 <= t2
		  t1)
		 ((zerop (logandc2 tag2 tag1)) ; t2 <= t1
		  t2)
		 (t
		  `(AND ,t1 ,t2))))
	  ((eq tag1 'CONS)
	   (cmpwarn-style "Unsupported CONS type ~S. Replacing it with T." t1)
	   t2)
	  ((eq tag2 'CONS)
	   (cmpwarn-style "Unsupported CONS type ~S. Replacing it with T." t2)
	   t1)
	  ((null tag1)

	   (unless (and (consp t1) (eq 'values (first t1)))

	     ;; handling of (values ...) is just broken right now.
	     ;; So there is no point complaining about it. JCB
	     (cmpwarn-style "Unknown type ~S. Assuming it is T." t1))
	   t2)
	  (t

	   (unless (and (consp t2) (eq 'values (first t2)))

	     ;; handling of (values ...) is just broken right now.
	     ;; So there is no point complaining about it. JCB
	     (cmpwarn-style "Unknown type ~S. Assuming it is T." t2))
	   t1))))

(defun type-or (t1 t2)
  ;; FIXME! Should we allow "*" as type name???
  (when (or (eq t1 t2) (eq t2 '*))
    (return-from type-or t1))
  (when (eq t1 '*)
    (return-from type-or t2))
  (let* ((si::*highest-type-tag* si::*highest-type-tag*)
	 (si::*save-types-database* t)
	 (si::*member-types* si::*member-types*)
	 (si::*elementary-types* si::*elementary-types*)
	 (tag1 (si::safe-canonical-type t1))
	 (tag2 (si::safe-canonical-type t2)))
    (cond ((and (numberp tag1) (numberp tag2))
	   (setf tag1 (si::safe-canonical-type t1)
		 tag2 (si::safe-canonical-type t2))
	   (cond ((zerop (logandc2 tag1 tag2)) ; t1 <= t2
		  t2)
		 ((zerop (logandc2 tag2 tag1)) ; t2 <= t1
		  t1)
		 (t
		  `(OR ,t1 ,t2))))
	  ((eq tag1 'CONS)
	   (cmpwarn-style "Unsupported CONS type ~S. Replacing it with T." t1)
	   T)
	  ((eq tag2 'CONS)
	   (cmpwarn-style "Unsupported CONS type ~S. Replacing it with T." t2)
	   T)
	  ((null tag1)

	   (unless (and (consp t1) (eq 'values (first t1)))

	     ;; handling of (values ...) is just broken right now.
	     ;; So there is no point complaining about it. JCB
	     (cmpwarn "Unknown type ~S" t1))
	   T)
	  (t

	   (unless (and (consp t2) (eq 'values (first t2)))