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

Contents of /src/tools/pclcom.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.22 - (hide annotations)
Thu Mar 15 18:01:39 2001 UTC (13 years, 1 month ago) by pw
Branch: MAIN
CVS Tags: LINKAGE_TABLE, PRE_LINKAGE_TABLE, UNICODE-BASE
Branch point for: UNICODE-BRANCH
Changes since 1.21: +4 -1 lines
Add support for ANSI specified :print-function and :print-object
defstruct options while preserving previous behaviour. ANSI processing
is enabled by ext:*ansi-defstruct-options-p* which must be NIL while
compiling CMUCL, PCL, CLX, HEMLOCK to avoid flushing defined print-functions.
This switch is turned ON when worldload builds a core with PCL in it.
1 dtc 1.19 ;;; -*- Package: USER -*-
2     ;;;
3     ;;; **********************************************************************
4     ;;;
5     (ext:file-comment
6 pw 1.22 "$Header: /tiger/var/lib/cvsroots/cmucl/src/tools/pclcom.lisp,v 1.22 2001/03/15 18:01:39 pw Exp $")
7 dtc 1.19 ;;;
8     ;;; **********************************************************************
9     ;;;
10 ram 1.1 (in-package "USER")
11    
12 wlott 1.4 (when (find-package "PCL")
13 dtc 1.13 ;; Load the lisp:documentation functions.
14     (load "target:code/misc")
15    
16 ram 1.10 ;;
17 dtc 1.13 ;; Blow away make-instance optimizer so that it doesn't confuse
18     ;; bootstrapping.
19 ram 1.12 (setf (compiler-macro-function 'make-instance) nil)
20 dtc 1.21 ;;
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 ram 1.12 ;;
26 ram 1.10 ;; 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 dtc 1.18 ;; 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 dtc 1.16 (rename-package "PCL" "OLD-PCL")
60     (make-package "PCL")
61 dtc 1.17 (shadowing-import class "PCL")
62 dtc 1.18 (kernel:%set-symbol-package class (find-package "PCL"))
63     (import slot-unbound "PCL")
64     (kernel:%set-symbol-package slot-unbound (find-package "PCL"))))
65 ram 1.10
66 ram 1.6 (when (find-package "SLOT-ACCESSOR-NAME")
67     (rename-package "SLOT-ACCESSOR-NAME" "OLD-SLOT-ACCESSOR-NAME"))
68 wlott 1.4
69 pw 1.15 (when (find-package "CLOS-MOP")
70     (rename-package "CLOS-MOP" "OLD-CLOS-MOP"))
71 pw 1.22
72     ;;; Inhibit ANSI :print-function and :print-object defstruct options.
73     (setq kernel::*ansi-defstruct-options-p* nil)
74 pw 1.15
75 ram 1.1 (setf c:*suppress-values-declaration* t)
76 ram 1.5 (pushnew :setf *features*)
77 ram 1.1
78     (setf (search-list "pcl:") '("target:pcl/"))
79    
80     (let ((obj (make-pathname :defaults "pcl:defsys"
81 dtc 1.14 :type (c:backend-byte-fasl-file-type c:*backend*))))
82 ram 1.1 (when (< (or (file-write-date obj) 0)
83     (file-write-date "pcl:defsys.lisp"))
84 ram 1.11 (compile-file "pcl:defsys" :byte-compile t)))
85 ram 1.1
86     (load "pcl:defsys" :verbose t)
87    
88     (import 'kernel:funcallable-instance-p (find-package "PCL"))
89    
90 ram 1.2 (with-compilation-unit
91 ram 1.9 (:optimize '(optimize (debug #+small .5 #-small 2)
92 ram 1.8 (speed 2) (safety #+small 0 #-small 2)
93 ram 1.3 (inhibit-warnings 2))
94 ram 1.8 :optimize-interface '(optimize-interface #+small (safety 1))
95 ram 1.3 :context-declarations
96 ram 1.9 '((:external (declare (optimize-interface (safety 2) (debug 1))))
97 ram 1.11 ((:or :macro (:match "$EARLY-") (:match "$BOOT-"))
98     (declare (optimize (speed 0))))))
99 ram 1.2 (pcl::compile-pcl))
100 dtc 1.20
101    
102     (cat-if-anything-changed
103     "pcl:gray-streams-library"
104     "pcl:gray-streams-class"
105     "pcl:gray-streams")

  ViewVC Help
Powered by ViewVC 1.1.5