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

Contents of /src/tools/pclcom.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.31 - (show annotations)
Wed Jun 18 10:50:14 2003 UTC (10 years, 10 months ago) by gerd
Branch: MAIN
CVS Tags: dynamic-extent-base, sparc_gencgc_merge, sparc_gencgc, lisp-executable-base
Branch point for: sparc_gencgc_branch, dynamic-extent, lisp-executable
Changes since 1.30: +2 -2 lines
	* src/tools/pclcom.lisp: Delete the symbol
	reinitialize-structure-class from kernel::*defstruct-hooks*
	instead of its function definition.
1 ;;; -*- Package: USER -*-
2 ;;;
3 ;;; **********************************************************************
4 ;;;
5 (ext:file-comment
6 "$Header: /tiger/var/lib/cvsroots/cmucl/src/tools/pclcom.lisp,v 1.31 2003/06/18 10:50:14 gerd Exp $")
7 ;;;
8 ;;; **********************************************************************
9 ;;;
10 (in-package "CL-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
27 ;; bootstrapping doesn't get confused, but convert condition
28 ;; accessor gfs to normal functions beforehand, for the obvious
29 ;; reason.
30 (when (fboundp 'conditions::make-early-condition-accessors-generic)
31 (conditions::make-early-condition-accessors-generic nil))
32 (let ((class (kernel::find-class 'generic-function nil)))
33 (when class
34 (do-external-symbols (sym "LISP")
35 (when (and (fboundp sym)
36 (typep (fdefinition sym) class))
37 (fmakunbound sym))
38 (let ((ssym `(setf ,sym)))
39 (when (and (fboundp ssym)
40 (typep (fdefinition ssym) class))
41 (fmakunbound ssym))))))
42
43 (let ((sym (find-symbol "%CHECK-GF-REDEFINITION" "PCL")))
44 (when sym
45 (setq lisp::*setf-fdefinition-hook*
46 (delete (symbol-function sym) lisp::*setf-fdefinition-hook*))))
47
48 (when (boundp 'kernel::*defstruct-hooks*)
49 (let ((sym (find-symbol "REINITIALIZE-STRUCTURE-CLASS" "PCL")))
50 (when sym
51 (setq kernel::*defstruct-hooks*
52 (delete sym kernel::*defstruct-hooks*)))))
53
54 ;; Undefine all PCL classes, and clear CLASS-PCL-CLASS slots.
55 (let ((wot (kernel::find-symbol "*FIND-CLASS*" "PCL")))
56 (when (and wot (boundp wot))
57 (do-hash (name ignore (symbol-value wot))
58 (declare (ignore ignore))
59 (let ((class (kernel::find-class name nil)))
60 (cond ((not class))
61 ((typep class 'kernel::std-class)
62 (setf (kernel:class-cell-class
63 (kernel:find-class-cell name))
64 nil)
65 (setf (info type kind name) nil))
66 (t
67 (setf (kernel:%class-pcl-class class) nil)))))))
68
69 ;; Rename the PCL package to OLD-PCL, then restoring pcl::class and
70 ;; pcl::..slot-unbound.. back to the PCL package as they need be
71 ;; consistent with the symbols recognised by the compiler.
72 (let ((slot-unbound 'pcl::..slot-unbound..))
73 (rename-package "PCL" "OLD-PCL")
74 (make-package "PCL")
75 (import slot-unbound "PCL")
76 (kernel:%set-symbol-package slot-unbound (find-package "PCL"))))
77
78 (when (find-package "CLOS-MOP")
79 (rename-package "CLOS-MOP" "OLD-CLOS-MOP"))
80
81 ;;; Inhibit ANSI :print-function and :print-object defstruct options.
82 (setq kernel::*ansi-defstruct-options-p* nil)
83
84 (setf c:*suppress-values-declaration* t)
85 (setf *features* (adjoin :setf *features*))
86
87 (setf (search-list "pcl:") '("target:pcl/"))
88
89 (let ((obj (make-pathname :defaults "pcl:defsys"
90 :type (c:backend-byte-fasl-file-type c:*backend*))))
91 (when (< (or (file-write-date obj) 0)
92 (file-write-date "pcl:defsys.lisp"))
93 (compile-file "pcl:defsys" :byte-compile t)))
94
95 (load "pcl:defsys" :verbose t)
96
97 (import 'kernel:funcallable-instance-p (find-package "PCL"))
98 (setq *gc-verbose* nil)
99
100 (with-compiler-log-file
101 ("target:compile-pcl.log"
102 :optimize '(optimize (debug #+small .5 #-small 2)
103 (speed 2) (safety #+small 0 #-small 2)
104 (inhibit-warnings 2))
105 :optimize-interface '(optimize-interface #+small (safety 1))
106 :context-declarations
107 '((:external (declare (optimize-interface (safety 2) (debug 1))))
108 ((:or :macro (:match "$EARLY-") (:match "$BOOT-"))
109 (declare (optimize (speed 0))))))
110 (pcl::compile-pcl))
111
112
113 (cat-if-anything-changed
114 "pcl:gray-streams-library"
115 "pcl:gray-streams-class"
116 "pcl:gray-streams")
117
118 (cat-if-anything-changed
119 "pcl:simple-streams-library"
120 "pcl:simple-streams/herald"
121 "pcl:simple-streams/classes"
122 "pcl:simple-streams/internal"
123 "pcl:simple-streams/strategy"
124 "pcl:simple-streams/impl"
125 "pcl:simple-streams/null"
126 "pcl:simple-streams/direct"
127 "pcl:simple-streams/file"
128 "pcl:simple-streams/string"
129 "pcl:simple-streams/terminal"
130 "pcl:simple-streams/socket")
131
132 (cat-if-anything-changed
133 "pcl:iodefs-library"
134 "pcl:simple-streams/iodefs")
135
136 (cat-if-anything-changed
137 "pcl:gray-compat-library"
138 "pcl:simple-streams/gray-compat")

  ViewVC Help
Powered by ViewVC 1.1.5