/[cmucl]/src/tools/pclcom.lisp
ViewVC logotype

Contents of /src/tools/pclcom.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.18 - (show annotations)
Thu Jun 25 18:45:29 1998 UTC (15 years, 9 months ago) by dtc
Branch: MAIN
Changes since 1.17: +8 -6 lines
Restore the pcl::..slot-unbound.. symbol back to the PCL package after
renaming the PCL to OLD-PCL package.
1
2 (in-package "USER")
3
4 (when (find-package "PCL")
5 ;; Load the lisp:documentation functions.
6 (load "target:code/misc")
7
8 ;;
9 ;; Blow away make-instance optimizer so that it doesn't confuse
10 ;; bootstrapping.
11 (setf (compiler-macro-function 'make-instance) nil)
12 ;;
13 ;; Undefine all generic functions exported from Lisp so that bootstrapping
14 ;; doesn't get confused.
15 (let ((class (find-class 'generic-function nil)))
16 (when class
17 (do-external-symbols (sym "LISP")
18 (when (and (fboundp sym)
19 (typep (fdefinition sym) class))
20 (fmakunbound sym))
21 (let ((ssym `(setf ,sym)))
22 (when (and (fboundp ssym)
23 (typep (fdefinition ssym) class))
24 (fmakunbound ssym))))))
25
26 ;; Undefine all PCL classes, and clear CLASS-PCL-CLASS slots.
27 (let ((wot (find-symbol "*FIND-CLASS*" "PCL")))
28 (when (and wot (boundp wot))
29 (do-hash (name ignore (symbol-value wot))
30 (declare (ignore ignore))
31 (let ((class (find-class name nil)))
32 (cond ((not class))
33 ((typep class 'kernel::std-class)
34 (setf (kernel:class-cell-class
35 (kernel:find-class-cell name))
36 nil)
37 (setf (info type kind name) nil))
38 (t
39 (setf (kernel:class-pcl-class class) nil)))))))
40
41 ;; Rename the PCL package to OLD-PCL, then restoring pcl::class and
42 ;; pcl::..slot-unbound.. back to the PCL package as they need be
43 ;; consistent with the symbols recognised by the compiler.
44 (let ((class 'pcl::class)
45 (slot-unbound 'pcl::..slot-unbound..))
46 (rename-package "PCL" "OLD-PCL")
47 (make-package "PCL")
48 (shadowing-import class "PCL")
49 (kernel:%set-symbol-package class (find-package "PCL"))
50 (import slot-unbound "PCL")
51 (kernel:%set-symbol-package slot-unbound (find-package "PCL"))))
52
53 (when (find-package "SLOT-ACCESSOR-NAME")
54 (rename-package "SLOT-ACCESSOR-NAME" "OLD-SLOT-ACCESSOR-NAME"))
55
56 (when (find-package "CLOS-MOP")
57 (rename-package "CLOS-MOP" "OLD-CLOS-MOP"))
58
59 (setf c:*suppress-values-declaration* t)
60 (pushnew :setf *features*)
61
62 (setf (search-list "pcl:") '("target:pcl/"))
63
64 (let ((obj (make-pathname :defaults "pcl:defsys"
65 :type (c:backend-byte-fasl-file-type c:*backend*))))
66 (when (< (or (file-write-date obj) 0)
67 (file-write-date "pcl:defsys.lisp"))
68 (compile-file "pcl:defsys" :byte-compile t)))
69
70 (load "pcl:defsys" :verbose t)
71
72 (import 'kernel:funcallable-instance-p (find-package "PCL"))
73
74 (with-compilation-unit
75 (:optimize '(optimize (debug #+small .5 #-small 2)
76 (speed 2) (safety #+small 0 #-small 2)
77 (inhibit-warnings 2))
78 :optimize-interface '(optimize-interface #+small (safety 1))
79 :context-declarations
80 '((:external (declare (optimize-interface (safety 2) (debug 1))))
81 ((:or :macro (:match "$EARLY-") (:match "$BOOT-"))
82 (declare (optimize (speed 0))))))
83 (pcl::compile-pcl))

  ViewVC Help
Powered by ViewVC 1.1.5