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

Contents of /src/tools/pclcom.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.22.2.1 - (hide annotations)
Sat May 22 12:13:45 2004 UTC (9 years, 10 months ago) by rtoy
Branch: UNICODE-BRANCH
Changes since 1.22: +52 -18 lines
Perform trivial merge from head to unicode-branch.
1 dtc 1.19 ;;; -*- Package: USER -*-
2     ;;;
3     ;;; **********************************************************************
4     ;;;
5     (ext:file-comment
6 rtoy 1.22.2.1 "$Header: /tiger/var/lib/cvsroots/cmucl/src/tools/pclcom.lisp,v 1.22.2.1 2004/05/22 12:13:45 rtoy Exp $")
7 dtc 1.19 ;;;
8     ;;; **********************************************************************
9     ;;;
10 rtoy 1.22.2.1 (in-package "CL-USER")
11     (setf lisp::*enable-package-locked-errors* nil)
12 ram 1.1
13 wlott 1.4 (when (find-package "PCL")
14 dtc 1.13 ;; Load the lisp:documentation functions.
15     (load "target:code/misc")
16    
17 ram 1.10 ;;
18 dtc 1.13 ;; Blow away make-instance optimizer so that it doesn't confuse
19     ;; bootstrapping.
20 ram 1.12 (setf (compiler-macro-function 'make-instance) nil)
21 dtc 1.21 ;;
22     ;; Blow away other compiler-macros exported from Lisp so that bootstrapping
23     ;; doesn't get confused.
24     (setf (compiler-macro-function 'slot-value) nil)
25     (setf (compiler-macro-function 'slot-boundp) nil)
26 ram 1.12 ;;
27 rtoy 1.22.2.1 ;; Undefine all generic functions exported from Lisp so that
28     ;; bootstrapping doesn't get confused, but convert condition
29     ;; accessor gfs to normal functions beforehand, for the obvious
30     ;; reason.
31     (when (fboundp 'conditions::make-early-condition-accessors-generic)
32     (conditions::make-early-condition-accessors-generic nil))
33     (let ((class (kernel::find-class 'generic-function nil)))
34 ram 1.10 (when class
35     (do-external-symbols (sym "LISP")
36     (when (and (fboundp sym)
37     (typep (fdefinition sym) class))
38     (fmakunbound sym))
39     (let ((ssym `(setf ,sym)))
40     (when (and (fboundp ssym)
41     (typep (fdefinition ssym) class))
42     (fmakunbound ssym))))))
43    
44 rtoy 1.22.2.1 (let ((sym (find-symbol "%CHECK-GF-REDEFINITION" "PCL")))
45     (when sym
46     (setq lisp::*setf-fdefinition-hook*
47     (delete (symbol-function sym) lisp::*setf-fdefinition-hook*))))
48    
49     (when (boundp 'kernel::*defstruct-hooks*)
50     (let ((sym (find-symbol "REINITIALIZE-STRUCTURE-CLASS" "PCL")))
51     (when sym
52     (setq kernel::*defstruct-hooks*
53     (delete sym kernel::*defstruct-hooks*)))))
54    
55 ram 1.10 ;; Undefine all PCL classes, and clear CLASS-PCL-CLASS slots.
56 rtoy 1.22.2.1 (let ((wot (kernel::find-symbol "*FIND-CLASS*" "PCL")))
57 ram 1.10 (when (and wot (boundp wot))
58     (do-hash (name ignore (symbol-value wot))
59     (declare (ignore ignore))
60 rtoy 1.22.2.1 (let ((class (kernel::find-class name nil)))
61 ram 1.10 (cond ((not class))
62     ((typep class 'kernel::std-class)
63     (setf (kernel:class-cell-class
64     (kernel:find-class-cell name))
65     nil)
66     (setf (info type kind name) nil))
67     (t
68 rtoy 1.22.2.1 (setf (kernel:%class-pcl-class class) nil)))))))
69 ram 1.10
70 dtc 1.18 ;; Rename the PCL package to OLD-PCL, then restoring pcl::class and
71     ;; pcl::..slot-unbound.. back to the PCL package as they need be
72     ;; consistent with the symbols recognised by the compiler.
73 rtoy 1.22.2.1 (let ((slot-unbound 'pcl::..slot-unbound..))
74 dtc 1.16 (rename-package "PCL" "OLD-PCL")
75     (make-package "PCL")
76 dtc 1.18 (import slot-unbound "PCL")
77     (kernel:%set-symbol-package slot-unbound (find-package "PCL"))))
78 ram 1.10
79 pw 1.15 (when (find-package "CLOS-MOP")
80     (rename-package "CLOS-MOP" "OLD-CLOS-MOP"))
81 pw 1.22
82     ;;; Inhibit ANSI :print-function and :print-object defstruct options.
83     (setq kernel::*ansi-defstruct-options-p* nil)
84 pw 1.15
85 ram 1.1 (setf c:*suppress-values-declaration* t)
86 rtoy 1.22.2.1 (setf *features* (adjoin :setf *features*))
87 ram 1.1
88     (setf (search-list "pcl:") '("target:pcl/"))
89    
90     (let ((obj (make-pathname :defaults "pcl:defsys"
91 dtc 1.14 :type (c:backend-byte-fasl-file-type c:*backend*))))
92 ram 1.1 (when (< (or (file-write-date obj) 0)
93     (file-write-date "pcl:defsys.lisp"))
94 ram 1.11 (compile-file "pcl:defsys" :byte-compile t)))
95 ram 1.1
96     (load "pcl:defsys" :verbose t)
97    
98     (import 'kernel:funcallable-instance-p (find-package "PCL"))
99 rtoy 1.22.2.1 (setq *gc-verbose* nil)
100 ram 1.1
101 rtoy 1.22.2.1 (with-compiler-log-file
102     ("target:compile-pcl.log"
103     :optimize '(optimize (debug #+small .5 #-small 2)
104 ram 1.8 (speed 2) (safety #+small 0 #-small 2)
105 ram 1.3 (inhibit-warnings 2))
106 ram 1.8 :optimize-interface '(optimize-interface #+small (safety 1))
107 ram 1.3 :context-declarations
108 ram 1.9 '((:external (declare (optimize-interface (safety 2) (debug 1))))
109 ram 1.11 ((:or :macro (:match "$EARLY-") (:match "$BOOT-"))
110     (declare (optimize (speed 0))))))
111 ram 1.2 (pcl::compile-pcl))
112 dtc 1.20
113    
114     (cat-if-anything-changed
115     "pcl:gray-streams-library"
116     "pcl:gray-streams-class"
117     "pcl:gray-streams")
118 rtoy 1.22.2.1
119     (cat-if-anything-changed
120     "pcl:simple-streams-library"
121     "pcl:simple-streams/herald"
122     "pcl:simple-streams/classes"
123     "pcl:simple-streams/internal"
124     "pcl:simple-streams/strategy"
125     "pcl:simple-streams/impl"
126     "pcl:simple-streams/null"
127     "pcl:simple-streams/direct"
128     "pcl:simple-streams/file"
129     "pcl:simple-streams/string"
130     "pcl:simple-streams/terminal"
131     "pcl:simple-streams/socket")
132    
133     (cat-if-anything-changed
134     "pcl:iodefs-library"
135     "pcl:simple-streams/iodefs")
136    
137     (cat-if-anything-changed
138     "pcl:gray-compat-library"
139     "pcl:simple-streams/gray-compat")

  ViewVC Help
Powered by ViewVC 1.1.5