boot1.lisp 5.18 KB
Newer Older
1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 21 22 23 24 25 26 27 28 29 30 31 32 33 34 35 36 37 38 39 40 41 42 43 44 45 46 47 48 49 50 51 52 53 54 55 56 57 58 59 60 61 62 63 64 65 66 67 68 69 70 71 72 73 74 75 76 77 78 79 80 81 82 83 84 85 86 87 88 89 90 91 92 93 94 95 96 97 98 99 100 101 102 103 104 105 106 107 108 109 110 111 112 113 114 115 116 117 118 119 120 121 122 123 124 125 126 127 128 129 130 131 132 133 134 135 136 137 138 139 140 141 142 143 144 145 146 147 148 149 150 151 152 153 154 155 156 157 158 159 160 161 162 163 164 165
;;;
;;; Bootstrap file 1 of 2 for moving LISP:CLASS and assorted functions
;;; and types to KERNEL, so that they are freed for use by PCL.
;;;
;;; Use this file as bootstrap.lisp, using Pierre Mai's build scripts,
;;; to cross-compile, resulting in a Lisp that is almost what we
;;; need to get to final result, except that it has still CLASS-NAME
;;; defined as a function, which needs to be corrected in a second
;;; build with the second bootstrap file of this series.
;;;

(in-package "LISP")

;;;
;;; Move the symbol whose name is NAME from LISP to KERNEL, and
;;; fix packages using that symbol.
;;;
(defun lisp-symbol->kernel (name)
  (let ((sym (find-symbol name :lisp)))
    (ext:collect ((pkgs))
      (dolist (p (list-all-packages))
	(when (eq (find-symbol name p) sym)
	  (pkgs p)))
      (unexport sym :lisp)
      (unintern sym :lisp)
      (import sym :kernel)
      (dolist (p (pkgs))
	(unless (eq (find-symbol name p) sym)
	  (import sym p))))))

;;;
;;; Move symbols we want to end up in KERNEL from LISP to KERNEL.
;;;
(defvar *symbols-to-move*
  '("CLASS"
    "BUILT-IN-CLASS"
    "STANDARD-CLASS"
    "STRUCTURE-CLASS"
    "FIND-CLASS"
    "CLASS-OF"))

(mapc #'lisp-symbol->kernel *symbols-to-move*)

;;;
;;; Redefine MAKE-PACKAGE because cross-compilation and build scripts
;;; rename some packages and make new ones.  We want to make sure that
;;; the new packages contain the symbols we imported from KERNEL
;;; in LISP-SYMBOL->KERNEL into the old package.
;;; 
(defun make-package (name &key (use *default-package-use-list*) nicknames
			  (internal-symbols 10) (external-symbols 10))
  "Makes a new package having the specified Name and Nicknames.  The
  package will inherit all external symbols from each package in
  the use list.  :Internal-Symbols and :External-Symbols are
  estimates for the number of internal and external symbols which
  will ultimately be present in the package."
  (when (find-package name)
    (cerror "Leave existing package alone."
	    "A package named ~S already exists" name))
  (let* ((name (package-namify name))
	 (package (internal-make-package
		   :%name name
		   :internal-symbols (make-package-hashtable internal-symbols)
		   :external-symbols (make-package-hashtable external-symbols))))
    (if *in-package-init*
	(push (list use package) *deferred-use-packages*)
	(use-package use package))
    (enter-new-nicknames package nicknames)
    (setf (gethash name *package-names*) package)
    (let ((old-pkg (find-package (concatenate 'string "OLD-" name))))
      (when (and old-pkg
		 (find-symbol (car *symbols-to-move*) old-pkg))
	(dolist (sym *symbols-to-move*)
	  (import (find-symbol sym "KERNEL") package))))
    package))

(in-package :kernel)

(export '(%class-layout %class-name %class-state
	  %class-direct-superclasses %class-subclasses %class-pcl-class))

;;;
;;; Like DEFSTRUCT, but silently clobber old definitions.
;;;
(defmacro defstruct! (name &rest stuff)
  `(handler-bind ((error (lambda (c)
			   (declare (ignore c))
			   (invoke-restart 'kernel::clobber-it))))
     (defstruct ,name ,@stuff)))

;;;
;;; Redefine CLASS in the compiling Lisp.
;;;
(defstruct! (class
	     (:conc-name %class-)
	     (:make-load-form-fun class-make-load-form-fun)
	     (:print-function %print-class)
	     (:include ctype
		       (:class-info (type-class-or-lose 'class)))
	     (:pure nil))
  (name nil)
  (layout nil :type (or layout null))
  (state nil :type (member nil :read-only :sealed))
  (direct-superclasses () :type list)
  (subclasses nil :type (or hash-table null))
  (pcl-class nil))

;;;
;;; Provide old accessors so that the compiling Lisp continues
;;; to work.
;;;
(macrolet ((def (o n)
	     `(progn
		(defun ,o (x) (,n x))
		(defun (setf ,o) (v x) (setf (,n x) v)))))
  (def class-layout %class-layout)
  (def class-name %class-name)
  (def class-state %class-state)
  (def class-direct-subclasses %class-direct-superclasses)
  (def class-subclasses %class-subclasses))

;;;
;;; This build feature is checked in code:class.lisp, and makes it
;;; define the same accessors as above.
;;;
(pushnew :bootstrap-lisp-class=pcl-class *features*)

;;;
;;; Redefine other affected structs.
;;;
(defstruct! (undefined-class
	     (:include class)
	     (:constructor make-undefined-class (name))))

(defstruct! (built-in-class (:include class))
  (translation nil :type (or ctype (member nil :initializing))))

(defstruct! (slot-class (:include class))
  (print-function nil :type (or function symbol null)))

(defstruct! (basic-structure-class (:include slot-class)))

(defstruct! (structure-class (:include basic-structure-class))
  (make-load-form-fun nil :type (or function symbol
				    (member :just-dump-it-normally
					    :ignore-it
					    nil)))
  (constructor nil :type (or function null)))

(defstruct! (funcallable-structure-class (:include basic-structure-class)))
(defstruct! (std-class (:include class)))
(defstruct! (standard-class (:include std-class)))
(defstruct! (random-pcl-class (:include std-class)))

(in-package "CONDITIONS")

(kernel::defstruct! (condition-class (:include slot-class))
  (slots nil :type list)
  (class-slots nil :type list)
  (report nil :type (or function null))
  (default-initargs () :type list)
  (cpl () :type list)
  (hairy-slots nil :type list))

;;; end of file