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

Contents of /src/tools/pclcom.lisp

Parent Directory Parent Directory | Revision Log Revision Log


Revision 1.28 - (hide annotations)
Fri Jun 6 16:23:46 2003 UTC (10 years, 10 months ago) by toy
Branch: MAIN
Changes since 1.27: +14 -1 lines
Initial import of Paul Foley's simple-streams implmentation.  Some
functionality is still missing, but Lisp streams and Gray streams
should behave unchanged.
1 dtc 1.19 ;;; -*- Package: USER -*-
2     ;;;
3     ;;; **********************************************************************
4     ;;;
5     (ext:file-comment
6 toy 1.28 "$Header: /tiger/var/lib/cvsroots/cmucl/src/tools/pclcom.lisp,v 1.28 2003/06/06 16:23:46 toy 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 gerd 1.27 ;; 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 gerd 1.24 (let ((class (kernel::find-class 'generic-function nil)))
33 ram 1.10 (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 gerd 1.24 (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 gerd 1.25
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 (symbol-function sym) kernel::*defstruct-hooks*)))))
53 gerd 1.24
54 ram 1.10 ;; Undefine all PCL classes, and clear CLASS-PCL-CLASS slots.
55 gerd 1.24 (let ((wot (kernel::find-symbol "*FIND-CLASS*" "PCL")))
56 ram 1.10 (when (and wot (boundp wot))
57     (do-hash (name ignore (symbol-value wot))
58     (declare (ignore ignore))
59 gerd 1.24 (let ((class (kernel::find-class name nil)))
60 ram 1.10 (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 gerd 1.24 (setf (kernel:%class-pcl-class class) nil)))))))
68 ram 1.10
69 dtc 1.18 ;; 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 gerd 1.24 (let ((slot-unbound 'pcl::..slot-unbound..))
73 dtc 1.16 (rename-package "PCL" "OLD-PCL")
74     (make-package "PCL")
75 dtc 1.18 (import slot-unbound "PCL")
76     (kernel:%set-symbol-package slot-unbound (find-package "PCL"))))
77 wlott 1.4
78 pw 1.15 (when (find-package "CLOS-MOP")
79     (rename-package "CLOS-MOP" "OLD-CLOS-MOP"))
80 pw 1.22
81     ;;; Inhibit ANSI :print-function and :print-object defstruct options.
82     (setq kernel::*ansi-defstruct-options-p* nil)
83 pw 1.15
84 ram 1.1 (setf c:*suppress-values-declaration* t)
85 gerd 1.24 (setf *features* (adjoin :setf *features*))
86 ram 1.1
87     (setf (search-list "pcl:") '("target:pcl/"))
88    
89     (let ((obj (make-pathname :defaults "pcl:defsys"
90 dtc 1.14 :type (c:backend-byte-fasl-file-type c:*backend*))))
91 ram 1.1 (when (< (or (file-write-date obj) 0)
92     (file-write-date "pcl:defsys.lisp"))
93 ram 1.11 (compile-file "pcl:defsys" :byte-compile t)))
94 ram 1.1
95     (load "pcl:defsys" :verbose t)
96    
97     (import 'kernel:funcallable-instance-p (find-package "PCL"))
98 gerd 1.24 (setq *gc-verbose* nil)
99 ram 1.1
100 toy 1.23 (with-compiler-log-file
101     ("target:compile-pcl.log"
102     :optimize '(optimize (debug #+small .5 #-small 2)
103 ram 1.8 (speed 2) (safety #+small 0 #-small 2)
104 ram 1.3 (inhibit-warnings 2))
105 ram 1.8 :optimize-interface '(optimize-interface #+small (safety 1))
106 ram 1.3 :context-declarations
107 ram 1.9 '((:external (declare (optimize-interface (safety 2) (debug 1))))
108 ram 1.11 ((:or :macro (:match "$EARLY-") (:match "$BOOT-"))
109     (declare (optimize (speed 0))))))
110 ram 1.2 (pcl::compile-pcl))
111 dtc 1.20
112    
113     (cat-if-anything-changed
114     "pcl:gray-streams-library"
115     "pcl:gray-streams-class"
116     "pcl:gray-streams")
117 toy 1.28
118     (cat-if-anything-changed
119     "pcl:simple-streams-library"
120     "pcl:simple-streams/classes"
121     "pcl:simple-streams/internal"
122     "pcl:simple-streams/strategy"
123     "pcl:simple-streams/impl"
124     "pcl:simple-streams/null"
125     "pcl:simple-streams/direct"
126     "pcl:simple-streams/file"
127     "pcl:simple-streams/string"
128     "pcl:simple-streams/terminal"
129     "pcl:simple-streams/socket")

  ViewVC Help
Powered by ViewVC 1.1.5