#|

This file is needed for source from somewhere early summer of 2000, if
you encounter the error below when compiling target:code/hash-new:

Error in function KERNEL::VALUES-SIMPLE-SUBTYPEP-TYPE-METHOD:
   Subtypep is illegal on this type:
  (VALUES BASE-STRING &REST T)

Restarts:
  0: [CONTINUE] Blow this file
  1:            Return NIL from load of "target:tools/worldcom".
  2:            Return NIL from load of "crabuild:build-the-subsystems".
  3: [ABORT   ] Skip remaining initializations.

Debug  (type H for help)

(KERNEL::VALUES-SIMPLE-SUBTYPEP-TYPE-METHOD
 #<VALUES-TYPE (VALUES BASE-STRING &REST T)>
 #<unavailable-arg>)

|#

(in-package "C")

(proclaim '(function parse-deftransform (list list symbol t)
	    (values list list)))
(proclaim '(function event-statistics (&optional unsigned-byte stream)
	    (values)))
(proclaim '(function clear-statistics () (values)))

(defun find-block-type-constraints (block)
  (declare (type cblock block))
  (let ((gen (make-sset)))
    (collect ((kill nil adjoin))

      (let ((test (block-test-constraint block)))
	(when test
	  (sset-union gen test)))
      
      (do-nodes (node cont block)
	(typecase node
	  (ref
	   (when (continuation-type-check cont)
	     (let ((var (ok-ref-lambda-var node)))
	       (when var
		 (let* ((atype (continuation-type cont))
			(con (find-constraint 'typep var atype nil)))
		   (sset-adjoin con gen))))))
	  (cset
	   (let ((var (set-var node)))
	     (when (lambda-var-p var)
	       (kill var)
	       (let ((cons (lambda-var-constraints var)))
		 (when cons
		   (sset-difference gen cons))))))))
      
      (setf (block-in block) nil)
      (setf (block-gen block) gen)
      (setf (block-kill block) (kill))
      (setf (block-out block) (copy-sset gen))
      (setf (block-type-asserted block) nil)
      (undefined-value))))

(defun use-result-constraints (block)
  (declare (type cblock block))
  (let ((in (block-in block)))

    (let ((test (block-test-constraint block)))
      (when test
	(sset-union in test)))

    (do-nodes (node cont block)
      (typecase node
	(ref
	 (let ((var (ref-leaf node)))
	   (when (lambda-var-p var)
	     (let ((con (lambda-var-constraints var)))
	       (when con
		 (constrain-ref-type node con in)
		 (when (continuation-type-check cont)
		   (sset-adjoin
		    (find-constraint 'typep var
				     (single-value-type
				      (continuation-asserted-type cont))
				     nil)
		    in)))))))
	(cset
	 (let ((var (set-var node)))
	   (when (lambda-var-p var)
	     (let ((cons (lambda-var-constraints var)))
	       (when cons
		 (sset-difference in cons))))))))))