;;; -*- Package: Lisp -*-
;;;
;;;    Patches to the bootstrapping environment for the new compiler.
;;;
(in-package 'lisp)

;;; This gives us an approximation of the function type cleanup.
;;;
(defun functionp (x) (compiled-function-p x))

;;; Allow constant folding of %string-char-p.
;;; 
(defun %string-char-p (x)
  (and (characterp x)
       (< (the fixnum (char-int x)) char-code-limit)))

;;; Base-char-p is really %string-char-p in the bootstrapping env.
;;;
(setf (symbol-function 'base-char-p)
      (symbol-function '%string-char-p))

;;; Allow constant folding of system-area-pointer-p.  There can't be any
;;; system-area-pointers in the bootstrap env, so this is easy.
;;;
(defun system-area-pointer-p (x)
  (declare (ignore x))
  nil)

;;; We need this, but lisp::type-expand has been uninterned.
;;; 
(defun old-compiler-type-expand (form)
  (let ((def (cond ((symbolp form)
		    (get form 'deftype-expander))
		   ((and (consp form) (symbolp (car form)))
		    (get (car form) 'deftype-expander))
		   (t nil))))
    (if def
	(type-expand (funcall def (if (consp form) form (list form))))
	form)))

;;; This is called if the type-specifier is a symbol and is not one of the
;;; built-in Lisp types.  If it's a structure, see if it's
;;; that type, or if it includes that type.  We allow testing against structure
;;; types that have been compiled but not loaded.  Any such test will fail,
;;; since there can't be any object of that type.

(defun structure-typep (object type)
  (let ((type (old-compiler-type-expand type)))
    (if (and (symbolp type)
	     (or (get type '%structure-definition)
		 (get type '%structure-definition-in-compiler)))
	(and (structurep object)
	     (let ((obj-name (svref object 0)))
	       (or (eq obj-name type)
		   (not (null (memq type
				    (dd-includes
				     (get obj-name
					  '%structure-definition))))))))
	(error "~S is an unknown type specifier." type))))

(defmacro truly-the (type x)
  `(the ,type ,x))