home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / pcl / src-16f.lha / compiler / patch.lisp < prev    next >
Encoding:
Text File  |  1991-11-06  |  1.9 KB  |  63 lines
  1. ;;; -*- Package: Lisp -*-
  2. ;;;
  3. ;;;    Patches to the bootstrapping environment for the new compiler.
  4. ;;;
  5. (in-package 'lisp)
  6.  
  7. ;;; This gives us an approximation of the function type cleanup.
  8. ;;;
  9. (defun functionp (x) (compiled-function-p x))
  10.  
  11. ;;; Allow constant folding of %string-char-p.
  12. ;;; 
  13. (defun %string-char-p (x)
  14.   (and (characterp x)
  15.        (< (the fixnum (char-int x)) char-code-limit)))
  16.  
  17. ;;; Base-char-p is really %string-char-p in the bootstrapping env.
  18. ;;;
  19. (setf (symbol-function 'base-char-p)
  20.       (symbol-function '%string-char-p))
  21.  
  22. ;;; Allow constant folding of system-area-pointer-p.  There can't be any
  23. ;;; system-area-pointers in the bootstrap env, so this is easy.
  24. ;;;
  25. (defun system-area-pointer-p (x)
  26.   (declare (ignore x))
  27.   nil)
  28.  
  29. ;;; We need this, but lisp::type-expand has been uninterned.
  30. ;;; 
  31. (defun old-compiler-type-expand (form)
  32.   (let ((def (cond ((symbolp form)
  33.             (get form 'deftype-expander))
  34.            ((and (consp form) (symbolp (car form)))
  35.             (get (car form) 'deftype-expander))
  36.            (t nil))))
  37.     (if def
  38.     (type-expand (funcall def (if (consp form) form (list form))))
  39.     form)))
  40.  
  41. ;;; This is called if the type-specifier is a symbol and is not one of the
  42. ;;; built-in Lisp types.  If it's a structure, see if it's
  43. ;;; that type, or if it includes that type.  We allow testing against structure
  44. ;;; types that have been compiled but not loaded.  Any such test will fail,
  45. ;;; since there can't be any object of that type.
  46.  
  47. (defun structure-typep (object type)
  48.   (let ((type (old-compiler-type-expand type)))
  49.     (if (and (symbolp type)
  50.          (or (get type '%structure-definition)
  51.          (get type '%structure-definition-in-compiler)))
  52.     (and (structurep object)
  53.          (let ((obj-name (svref object 0)))
  54.            (or (eq obj-name type)
  55.            (not (null (memq type
  56.                     (dd-includes
  57.                      (get obj-name
  58.                       '%structure-definition))))))))
  59.     (error "~S is an unknown type specifier." type))))
  60.  
  61. (defmacro truly-the (type x)
  62.   `(the ,type ,x))
  63.