pclcom.lisp 4.51 KB
Newer Older
1 2 3 4 5
;;; -*- Package: USER -*-
;;;
;;; **********************************************************************
;;;
(ext:file-comment
6
  "$Header: src/tools/pclcom.lisp $")
7 8 9
;;;
;;; **********************************************************************
;;;
10
(in-package "CL-USER")
11
(setf lisp::*enable-package-locked-errors* nil)
ram's avatar
ram committed
12

13
(when (find-package "PCL")
14 15 16
  ;; Load the lisp:documentation functions.
  (load "target:code/misc")

17
  ;;
18 19
  ;; Blow away make-instance optimizer so that it doesn't confuse
  ;; bootstrapping.
20
  (setf (compiler-macro-function 'make-instance) nil)
21
  ;;
22 23 24 25 26
  ;; Blow away other compiler-macros exported from Lisp so that bootstrapping
  ;; doesn't get confused.
  (setf (compiler-macro-function 'slot-value) nil)
  (setf (compiler-macro-function 'slot-boundp) nil)
  ;;
27 28 29 30 31 32
  ;; Undefine all generic functions exported from Lisp so that
  ;; bootstrapping doesn't get confused, but convert condition
  ;; accessor gfs to normal functions beforehand, for the obvious
  ;; reason.
  (when (fboundp 'conditions::make-early-condition-accessors-generic)
    (conditions::make-early-condition-accessors-generic nil))
33
  (let ((class (kernel::find-class 'generic-function nil)))
34 35 36 37 38 39 40 41 42 43
    (when class
      (do-external-symbols (sym "LISP")
	(when (and (fboundp sym)
		   (typep (fdefinition sym) class))
	  (fmakunbound sym))
	(let ((ssym `(setf ,sym)))
	  (when (and (fboundp ssym)
		     (typep (fdefinition ssym) class))
	    (fmakunbound ssym))))))

44 45 46 47 48
  (let ((sym (find-symbol "%CHECK-GF-REDEFINITION" "PCL")))
    (when sym
      (setq lisp::*setf-fdefinition-hook*
	    (delete (symbol-function sym) lisp::*setf-fdefinition-hook*))))

49 50 51 52
  (when (boundp 'kernel::*defstruct-hooks*)
    (let ((sym (find-symbol "REINITIALIZE-STRUCTURE-CLASS" "PCL")))
      (when sym
	(setq kernel::*defstruct-hooks*
53
	      (delete sym kernel::*defstruct-hooks*)))))
54

55
  ;; Undefine all PCL classes, and clear CLASS-PCL-CLASS slots.
56
  (let ((wot (kernel::find-symbol "*FIND-CLASS*" "PCL")))
57 58 59
    (when (and wot (boundp wot))
      (do-hash (name ignore (symbol-value wot))
	(declare (ignore ignore))
60
	(let ((class (kernel::find-class name nil)))
61 62 63 64 65 66 67
	  (cond ((not class))
		((typep class 'kernel::std-class)
		 (setf (kernel:class-cell-class
			(kernel:find-class-cell name))
		       nil)
		 (setf (info type kind name) nil))
		(t
68
		 (setf (kernel:%class-pcl-class class) nil)))))))
69

70 71 72
  ;; Rename the PCL package to OLD-PCL, then restoring pcl::class and
  ;; pcl::..slot-unbound.. back to the PCL package as they need be
  ;; consistent with the symbols recognised by the compiler.
73
  (let ((slot-unbound 'pcl::..slot-unbound..))
74 75
    (rename-package "PCL" "OLD-PCL")
    (make-package "PCL")
76 77
    (import slot-unbound "PCL")
    (kernel:%set-symbol-package slot-unbound (find-package "PCL"))))
78

79 80 81
(when (find-package "CLOS-MOP")
  (rename-package "CLOS-MOP" "OLD-CLOS-MOP"))

82 83 84
;;; Inhibit ANSI :print-function and :print-object defstruct options.
(setq kernel::*ansi-defstruct-options-p* nil)

ram's avatar
ram committed
85
(setf c:*suppress-values-declaration* t)
86
(setf *features* (adjoin :setf *features*))
ram's avatar
ram committed
87 88 89 90

(setf (search-list "pcl:") '("target:pcl/"))

(let ((obj (make-pathname :defaults "pcl:defsys"
91
			  :type (c:backend-byte-fasl-file-type c:*backend*))))
ram's avatar
ram committed
92 93
  (when (< (or (file-write-date obj) 0)
	   (file-write-date "pcl:defsys.lisp"))
94
    (compile-file "pcl:defsys" :byte-compile t)))
ram's avatar
ram committed
95 96 97 98

(load "pcl:defsys" :verbose t)

(import 'kernel:funcallable-instance-p (find-package "PCL"))
99
(setq *gc-verbose* nil)
ram's avatar
ram committed
100

toy's avatar
toy committed
101 102 103
(with-compiler-log-file
    ("target:compile-pcl.log"
     :optimize '(optimize (debug #+small .5 #-small 2)
104
			  (speed 2) (safety #+small 0 #-small 2)
105
			  (inhibit-warnings 2))
106
     :optimize-interface '(optimize-interface #+small (safety 1))
107
     :context-declarations
ram's avatar
ram committed
108
     '((:external (declare (optimize-interface (safety 2) (debug 1))))
109 110
       ((:or :macro (:match "$EARLY-") (:match "$BOOT-"))
	(declare (optimize (speed 0))))))
111
 (pcl::compile-pcl))
112 113 114 115 116 117


(cat-if-anything-changed
 "pcl:gray-streams-library"
 "pcl:gray-streams-class"
 "pcl:gray-streams")
118 119 120

(cat-if-anything-changed
 "pcl:simple-streams-library"
121
 "pcl:simple-streams/herald"
122 123 124 125 126 127 128 129 130
 "pcl:simple-streams/classes"
 "pcl:simple-streams/internal"
 "pcl:simple-streams/strategy"
 "pcl:simple-streams/impl"
 "pcl:simple-streams/null"
 "pcl:simple-streams/direct"
 "pcl:simple-streams/file"
 "pcl:simple-streams/string"
 "pcl:simple-streams/terminal"
131 132 133 134
 "pcl:simple-streams/socket";)
 "pcl:simple-streams/iodefs"
 "pcl:simple-streams/gray-compat")

135 136 137 138 139 140 141
(cat-if-anything-changed
 "pcl:iodefs-library"
 "pcl:simple-streams/iodefs")

(cat-if-anything-changed
 "pcl:gray-compat-library"
 "pcl:simple-streams/gray-compat")