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

Contents of /src/tools/pclcom.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.12.2.6 - (show annotations)
Thu Jun 29 07:52:30 2000 UTC (13 years, 9 months ago) by dtc
Branch: RELENG_18
CVS Tags: RELEASE_18c
Changes since 1.12.2.5: +6 -1 lines
Blow away the slot-value and slot-boundp compiler-macros exported from
Lisp when bootstrapping from a lisp core that includes PCL. This overcomes
trouble noted compiling Gray streams from a core that includes PCL.
1 ;;; -*- Package: USER -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;;
5 (ext:file-comment
6 "$Header: /tiger/var/lib/cvsroots/cmucl/src/tools/pclcom.lisp,v 1.12.2.6 2000/06/29 07:52:30 dtc Exp $")
7 ;;;
8 ;;; **********************************************************************
9 ;;;
10 (in-package "USER")
11
12 (when (find-package "PCL")
13 ;; Load the lisp:documentation functions.
14 (load "target:code/misc")
15
16 ;;
17 ;; Blow away make-instance optimizer so that it doesn't confuse
18 ;; bootstrapping.
19 (setf (compiler-macro-function 'make-instance) nil)
20 ;;
21 ;; Blow away other compiler-macros exported from Lisp so that bootstrapping
22 ;; doesn't get confused.
23 (setf (compiler-macro-function 'slot-value) nil)
24 (setf (compiler-macro-function 'slot-boundp) nil)
25 ;;
26 ;; Undefine all generic functions exported from Lisp so that bootstrapping
27 ;; doesn't get confused.
28 (let ((class (find-class 'generic-function nil)))
29 (when class
30 (do-external-symbols (sym "LISP")
31 (when (and (fboundp sym)
32 (typep (fdefinition sym) class))
33 (fmakunbound sym))
34 (let ((ssym `(setf ,sym)))
35 (when (and (fboundp ssym)
36 (typep (fdefinition ssym) class))
37 (fmakunbound ssym))))))
38
39 ;; Undefine all PCL classes, and clear CLASS-PCL-CLASS slots.
40 (let ((wot (find-symbol "*FIND-CLASS*" "PCL")))
41 (when (and wot (boundp wot))
42 (do-hash (name ignore (symbol-value wot))
43 (declare (ignore ignore))
44 (let ((class (find-class name nil)))
45 (cond ((not class))
46 ((typep class 'kernel::std-class)
47 (setf (kernel:class-cell-class
48 (kernel:find-class-cell name))
49 nil)
50 (setf (info type kind name) nil))
51 (t
52 (setf (kernel:class-pcl-class class) nil)))))))
53
54 ;; Rename the PCL package to OLD-PCL, then restoring pcl::class and
55 ;; pcl::..slot-unbound.. back to the PCL package as they need be
56 ;; consistent with the symbols recognised by the compiler.
57 (let ((class 'pcl::class)
58 (slot-unbound 'pcl::..slot-unbound..))
59 (rename-package "PCL" "OLD-PCL")
60 (make-package "PCL")
61 (shadowing-import class "PCL")
62 (kernel:%set-symbol-package class (find-package "PCL"))
63 (import slot-unbound "PCL")
64 (kernel:%set-symbol-package slot-unbound (find-package "PCL"))))
65
66 (when (find-package "SLOT-ACCESSOR-NAME")
67 (rename-package "SLOT-ACCESSOR-NAME" "OLD-SLOT-ACCESSOR-NAME"))
68
69 (when (find-package "CLOS-MOP")
70 (rename-package "CLOS-MOP" "OLD-CLOS-MOP"))
71
72 (setf c:*suppress-values-declaration* t)
73 (pushnew :setf *features*)
74
75 (setf (search-list "pcl:") '("target:pcl/"))
76
77 (let ((obj (make-pathname :defaults "pcl:defsys"
78 :type (c:backend-byte-fasl-file-type c:*backend*))))
79 (when (< (or (file-write-date obj) 0)
80 (file-write-date "pcl:defsys.lisp"))
81 (compile-file "pcl:defsys" :byte-compile t)))
82
83 (load "pcl:defsys" :verbose t)
84
85 (import 'kernel:funcallable-instance-p (find-package "PCL"))
86
87 (with-compilation-unit
88 (:optimize '(optimize (debug #+small .5 #-small 2)
89 (speed 2) (safety #+small 0 #-small 2)
90 (inhibit-warnings 2))
91 :optimize-interface '(optimize-interface #+small (safety 1))
92 :context-declarations
93 '((:external (declare (optimize-interface (safety 2) (debug 1))))
94 ((:or :macro (:match "$EARLY-") (:match "$BOOT-"))
95 (declare (optimize (speed 0))))))
96 (pcl::compile-pcl))
97
98
99 (cat-if-anything-changed
100 "pcl:gray-streams-library"
101 "pcl:gray-streams-class"
102 "pcl:gray-streams")

  ViewVC Help
Powered by ViewVC 1.1.5