1 ;;;; This software is part of the SBCL system. See the README file for
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.
10 (in-package "SB-COLD")
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
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
22 package-data-import-from
24 (defstruct package-data
25 ;; a string designator for the package name
26 (name (error "missing PACKAGE-DATA-NAME datum"))
28 (doc (error "missing PACKAGE-DOC datum"))
29 ;; a tree containing names for exported symbols which'll be set up at package
30 ;; creation time, and NILs, which are ignored. (This is a tree in order to
31 ;; allow constructs like '("ENOSPC" #!+LINUX ("EDQUOT" "EISNAM" "ENAVAIL"
32 ;; "EREMOTEIO")) to be used in initialization. NIL entries in the tree are
33 ;; ignored for the same reason of notational convenience.)
35 ;; a list of string designators for exported symbols which don't necessarily
36 ;; originate in this package (so their EXPORT operations should be handled
37 ;; after USE operations have been done, so that duplicates aren't created)
39 ;; a list of sublists describing imports. Each sublist has the format as an
40 ;; IMPORT-FROM list in DEFPACKAGE: the first element is the name of the
41 ;; package to import from, and the remaining elements are the names of
44 ;; a tree of string designators for package names of other packages
45 ;; which this package uses
48 (let ((package-data-list (read-from-file "package-data-list.lisp-expr")))
49 (labels ((flatten (tree)
50 (mapcan (lambda (x) (if (listp x
) (flatten x
) (list x
)))
53 ;; Build all packages that we need, and initialize them as far as we
54 ;; can without referring to any other packages.
55 (dolist (package-data package-data-list
)
56 (let* ((package (make-package
57 (package-data-name package-data
)
58 ;; Note: As of 0.7.0, the only nicknames we use
59 ;; for our implementation packages are hacks
60 ;; not needed at cross-compile time (e.g. the
61 ;; deprecated SB-C-CALL nickname for SB-ALIEN).
62 ;; So support for nicknaming during xc is gone,
63 ;; since any nicknames are hacked in during
67 ;; Walk the tree of exported names, exporting each name.
68 (dolist (string (flatten (package-data-export package-data
)))
69 (export (intern string package
) package
))))
71 ;; Now that all packages exist, we can set up package-package
73 (dolist (package-data package-data-list
)
74 (use-package (package-data-use package-data
)
75 (package-data-name package-data
))
76 (dolist (sublist (package-data-import-from package-data
))
77 (let* ((from-package (first sublist
))
78 (symbol-names (rest sublist
))
79 (symbols (mapcar (lambda (name)
80 ;; old way, broke for importing symbols
81 ;; like SB!C::DEBUG-SOURCE-FORM into
82 ;; SB!DI -- WHN 19990714
84 (let ((s (find-symbol name from-package
)))
86 (error "can't find ~S in ~S"
90 ;; new way, works for SB!DI stuff
92 (intern name from-package
))
93 (flatten symbol-names
))))
94 (import symbols
(package-data-name package-data
)))))
96 ;; Now that all package-package references exist, we can handle
97 ;; REEXPORT operations. (We have to wait until now because they
98 ;; interact with USE operations.) This code handles dependencies
99 ;; properly, but is somewhat ugly.
102 ((reexport (package-data)
103 (let ((package (find-package (package-data-name package-data
))))
105 ((member package done
))
106 ((null (package-data-reexport package-data
))
112 (member x
(package-data-use package-data
)
115 :key
#'package-data-name
))
117 (flatten (package-data-reexport package-data
)))
118 (multiple-value-bind (symbol status
)
119 (find-symbol symbol-name package
)
121 (error "No symbol named ~S is accessible in ~S."
122 symbol-name package
))
123 (when (eq (symbol-package symbol
) package
)
125 "~S is not inherited/imported, but native to ~S."
126 symbol-name package
))
127 (export symbol package
)))
128 (push package done
))))))
129 (dolist (x package-data-list
)
131 (assert (= (length done
) (length package-data-list
)))))))