1.0.6.46: better standard-specializer-p implementation
[sbcl.git] / src / cold / set-up-cold-packages.lisp
1 ;;;; This software is part of the SBCL system. See the README file for
2 ;;;; more information.
3 ;;;;
4 ;;;; This software is derived from the CMU CL system, which was
5 ;;;; written at Carnegie Mellon University and released into the
6 ;;;; public domain. The software is in the public domain and is
7 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
8 ;;;; files for more information.
9
10 (in-package "SB-COLD")
11
12 ;;; an entry in the table which describes the non-standard part (i.e. not
13 ;;; CL/CL-USER/KEYWORD) of the package structure of the SBCL system
14 ;;;
15 ;;; We make no attempt to be fully general; our table doesn't need to be
16 ;;; able to express features which we don't happen to use.
17 (export '(package-data
18           package-data-name
19           package-data-export
20           package-data-reexport
21           package-data-import-from
22           package-data-use))
23 (defstruct package-data
24   ;; a string designator for the package name
25   (name (error "missing PACKAGE-DATA-NAME datum"))
26   ;; a doc string
27   (doc (error "missing PACKAGE-DOC datum"))
28   ;; a tree containing names for exported symbols which'll be set up at package
29   ;; creation time, and NILs, which are ignored. (This is a tree in order to
30   ;; allow constructs like '("ENOSPC" #!+LINUX ("EDQUOT" "EISNAM" "ENAVAIL"
31   ;; "EREMOTEIO")) to be used in initialization. NIL entries in the tree are
32   ;; ignored for the same reason of notational convenience.)
33   export
34   ;; a list of string designators for exported symbols which don't necessarily
35   ;; originate in this package (so their EXPORT operations should be handled
36   ;; after USE operations have been done, so that duplicates aren't created)
37   reexport
38   ;; a list of sublists describing imports. Each sublist has the format as an
39   ;; IMPORT-FROM list in DEFPACKAGE: the first element is the name of the
40   ;; package to import from, and the remaining elements are the names of
41   ;; symbols to import.
42   import-from
43   ;; a tree of string designators for package names of other packages
44   ;; which this package uses
45   use)
46
47 (let ((package-data-list (read-from-file "package-data-list.lisp-expr")))
48
49     ;; Build all packages that we need, and initialize them as far as we
50     ;; can without referring to any other packages.
51     (dolist (package-data package-data-list)
52       (let* ((package (make-package
53                        (package-data-name package-data)
54                        ;; Note: As of 0.7.0, the only nicknames we use
55                        ;; for our implementation packages are hacks
56                        ;; not needed at cross-compile time (e.g. the
57                        ;; deprecated SB-C-CALL nickname for SB-ALIEN).
58                        ;; So support for nicknaming during xc is gone,
59                        ;; since any nicknames are hacked in during
60                        ;; cold init.
61                        :nicknames nil
62                        :use nil)))
63         #-clisp ; As of "2.27 (released 2001-07-17) (built 3215971334)"
64                 ; CLISP didn't support DOCUMENTATION on PACKAGE values.
65         (progn
66           #!+sb-doc (setf (documentation package t)
67                           (package-data-doc package-data)))
68         ;; Walk the tree of exported names, exporting each name.
69         (labels ((recurse (tree)
70                    (etypecase tree
71                      ;; FIXME: The comments above say the structure is a tree,
72                      ;; but here we're sleazily treating it as though
73                      ;; dotted lists never occur. Replace this LIST case
74                      ;; with separate NULL and CONS cases to fix this.
75                      (list (mapc #'recurse tree))
76                      (string (export (intern tree package) package)))))
77           (recurse (package-data-export package-data)))))
78
79     ;; Now that all packages exist, we can set up package-package
80     ;; references.
81     (dolist (package-data package-data-list)
82       (use-package (package-data-use package-data)
83                    (package-data-name package-data))
84       (dolist (sublist (package-data-import-from package-data))
85         (let* ((from-package (first sublist))
86                (symbol-names (rest sublist))
87                (symbols (mapcar (lambda (name)
88                                   ;; old way, broke for importing symbols
89                                   ;; like SB!C::DEBUG-SOURCE-FORM into
90                                   ;; SB!DI -- WHN 19990714
91                                   #+nil
92                                   (let ((s (find-symbol name from-package)))
93                                     (unless s
94                                       (error "can't find ~S in ~S"
95                                              name
96                                              from-package))
97                                     s)
98                                   ;; new way, works for SB!DI stuff
99                                   ;; -- WHN 19990714
100                                   (intern name from-package))
101                                 symbol-names)))
102           (import symbols (package-data-name package-data)))))
103
104     ;; Now that all package-package references exist, we can handle
105     ;; REEXPORT operations. (We have to wait until now because they
106     ;; interact with USE operations.)  This code handles dependencies
107     ;; properly, but is somewhat ugly.
108     (let (done)
109       (labels
110           ((reexport (package-data)
111              (let ((package (find-package (package-data-name package-data))))
112                (cond
113                  ((member package done))
114                  ((null (package-data-reexport package-data))
115                   (push package done))
116                  (t
117                   (mapcar #'reexport
118                           (remove-if-not
119                            (lambda (x)
120                              (member x (package-data-use package-data)
121                                      :test #'string=))
122                            package-data-list
123                            :key #'package-data-name))
124                   (dolist (symbol-name (package-data-reexport package-data))
125                     (multiple-value-bind (symbol status)
126                         (find-symbol symbol-name package)
127                       (unless status
128                         (error "No symbol named ~S is accessible in ~S."
129                                symbol-name package))
130                       (when (eq (symbol-package symbol) package)
131                         (error
132                          "~S is not inherited/imported, but native to ~S."
133                          symbol-name package))
134                       (export symbol package)))
135                   (push package done))))))
136         (dolist (x package-data-list)
137           (reexport x))
138         (assert (= (length done) (length package-data-list))))))