1.0.11.34: better SUBSEQ on lists
[sbcl.git] / src / code / package.lisp
1 ;;;; that part of the CMU CL package.lisp file which can run on the
2 ;;;; cross-compilation host
3
4 ;;;; This software is part of the SBCL system. See the README file for
5 ;;;; more information.
6 ;;;;
7 ;;;; This software is derived from the CMU CL system, which was
8 ;;;; written at Carnegie Mellon University and released into the
9 ;;;; public domain. The software is in the public domain and is
10 ;;;; provided with absolutely no warranty. See the COPYING and CREDITS
11 ;;;; files for more information.
12
13 (in-package "SB!IMPL")
14 \f
15 ;;;; the PACKAGE-HASHTABLE structure
16
17 ;;; comment from CMU CL:
18 ;;;      Packages are implemented using a special kind of hashtable. It is
19 ;;;   an open hashtable with a parallel 8-bit I-vector of hash-codes. The
20 ;;;   primary purpose of the hash for each entry is to reduce paging by
21 ;;;   allowing collisions and misses to be detected without paging in the
22 ;;;   symbol and pname for an entry. If the hash for an entry doesn't
23 ;;;   match that for the symbol that we are looking for, then we can
24 ;;;   go on without touching the symbol, pname, or even hastable vector.
25 ;;;      It turns out that, contrary to my expectations, paging is a very
26 ;;;   important consideration the design of the package representation.
27 ;;;   Using a similar scheme without the entry hash, the fasloader was
28 ;;;   spending more than half its time paging in INTERN.
29 ;;;      The hash code also indicates the status of an entry. If it zero,
30 ;;;   the entry is unused. If it is one, then it is deleted.
31 ;;;   Double-hashing is used for collision resolution.
32
33 (def!type hash-vector () '(simple-array (unsigned-byte 8) (*)))
34
35 (def!struct (package-hashtable
36              (:constructor %make-package-hashtable
37                            (table hash size &aux (free size)))
38              (:copier nil))
39   ;; The g-vector of symbols.
40   (table (missing-arg) :type simple-vector)
41   ;; The i-vector of pname hash values.
42   (hash (missing-arg) :type hash-vector)
43   ;; The total number of entries allowed before resizing.
44   ;;
45   ;; FIXME: CAPACITY would be a more descriptive name. (This is
46   ;; related to but not quite the same as HASH-TABLE-SIZE, so calling
47   ;; it SIZE seems somewhat misleading.)
48   (size (missing-arg) :type index)
49   ;; The remaining number of entries that can be made before we have to rehash.
50   (free (missing-arg) :type index)
51   ;; The number of deleted entries.
52   (deleted 0 :type index))
53 \f
54 ;;;; the PACKAGE structure
55
56 ;;; KLUDGE: We use DEF!STRUCT to define this not because we need to
57 ;;; manipulate target package objects on the cross-compilation host,
58 ;;; but only because its MAKE-LOAD-FORM function needs to be hooked
59 ;;; into the pre-CLOS DEF!STRUCT MAKE-LOAD-FORM system so that we can
60 ;;; compile things like IN-PACKAGE in warm init before CLOS is set up.
61 ;;; The DEF!STRUCT side effect of defining a new PACKAGE type on the
62 ;;; cross-compilation host is just a nuisance, and in order to avoid
63 ;;; breaking the cross-compilation host, we need to work around it
64 ;;; around by putting the new PACKAGE type (and the PACKAGEP predicate
65 ;;; too..) into SB!XC. -- WHN 20000309
66 (def!struct (sb!xc:package
67              (:constructor internal-make-package)
68              (:make-load-form-fun (lambda (p)
69                                     (values `(find-undeleted-package-or-lose
70                                               ',(package-name p))
71                                             nil)))
72              (:predicate sb!xc:packagep))
73   #!+sb-doc
74   "the standard structure for the description of a package"
75   ;; the name of the package, or NIL for a deleted package
76   (%name nil :type (or simple-string null))
77   ;; nickname strings
78   (%nicknames () :type list)
79   ;; packages used by this package
80   (%use-list () :type list)
81   ;; a list of all the hashtables for inherited symbols. This is
82   ;; derived from %USE-LIST, but maintained separately from %USE-LIST
83   ;; for some reason. (Perhaps the reason is that when FIND-SYMBOL*
84   ;; hits an inherited symbol, it pulls it to the head of the list.)
85   ;;
86   ;; FIXME: This needs a more-descriptive name
87   ;; (USED-PACKAGE-HASH-TABLES?). It also needs an explanation of why
88   ;; the last entry is NIL. Perhaps it should even just go away and
89   ;; let us do indirection on the fly through %USE-LIST. (If so,
90   ;; benchmark to make sure that performance doesn't get stomped..)
91   ;; (If benchmark performance is important, this should prob'ly
92   ;; become a vector instead of a list.)
93   (tables (list nil) :type list)
94   ;; packages that use this package
95   (%used-by-list () :type list)
96   ;; PACKAGE-HASHTABLEs of internal & external symbols
97   (internal-symbols (missing-arg) :type package-hashtable)
98   (external-symbols (missing-arg) :type package-hashtable)
99   ;; shadowing symbols
100   (%shadowing-symbols () :type list)
101   ;; documentation string for this package
102   (doc-string nil :type (or simple-string null))
103   ;; package locking
104   #!+sb-package-locks
105   (lock nil :type boolean)
106   #!+sb-package-locks
107   (%implementation-packages nil :type list)
108   ;; Definition source location
109   (source-location nil :type (or null sb!c:definition-source-location)))
110 \f
111 ;;;; iteration macros
112
113 (defmacro-mundanely do-symbols ((var &optional
114                                      (package '*package*)
115                                      result-form)
116                                 &body body-decls)
117   #!+sb-doc
118   "DO-SYMBOLS (VAR [PACKAGE [RESULT-FORM]]) {DECLARATION}* {TAG | FORM}*
119    Executes the FORMs at least once for each symbol accessible in the given
120    PACKAGE with VAR bound to the current symbol."
121   (multiple-value-bind (body decls)
122       (parse-body body-decls :doc-string-allowed nil)
123     (let ((flet-name (gensym "DO-SYMBOLS-")))
124       `(block nil
125          (flet ((,flet-name (,var)
126                   ,@decls
127                   (tagbody ,@body)))
128            (let* ((package (find-undeleted-package-or-lose ,package))
129                   (shadows (package-%shadowing-symbols package)))
130              (flet ((iterate-over-hash-table (table ignore)
131                       (let ((hash-vec (package-hashtable-hash table))
132                             (sym-vec (package-hashtable-table table)))
133                         (dotimes (i (length sym-vec))
134                           (when (>= (aref hash-vec i) 2)
135                             (let ((sym (aref sym-vec i)))
136                               (declare (inline member))
137                               (unless (member sym ignore :test #'string=)
138                                 (,flet-name sym))))))))
139                (iterate-over-hash-table (package-internal-symbols package) nil)
140                (iterate-over-hash-table (package-external-symbols package) nil)
141                (dolist (use (package-%use-list package))
142                  (iterate-over-hash-table (package-external-symbols use)
143                                           shadows)))))
144          (let ((,var nil))
145            (declare (ignorable ,var))
146            ,@decls
147            ,result-form)))))
148
149 (defmacro-mundanely do-external-symbols ((var &optional
150                                               (package '*package*)
151                                               result-form)
152                                          &body body-decls)
153   #!+sb-doc
154   "DO-EXTERNAL-SYMBOLS (VAR [PACKAGE [RESULT-FORM]]) {DECL}* {TAG | FORM}*
155    Executes the FORMs once for each external symbol in the given PACKAGE with
156    VAR bound to the current symbol."
157   (multiple-value-bind (body decls)
158       (parse-body body-decls :doc-string-allowed nil)
159     (let ((flet-name (gensym "DO-SYMBOLS-")))
160       `(block nil
161          (flet ((,flet-name (,var)
162                   ,@decls
163                   (tagbody ,@body)))
164            (let* ((package (find-undeleted-package-or-lose ,package))
165                   (table (package-external-symbols package))
166                   (hash-vec (package-hashtable-hash table))
167                   (sym-vec (package-hashtable-table table)))
168              (dotimes (i (length sym-vec))
169                (when (>= (aref hash-vec i) 2)
170                  (,flet-name (aref sym-vec i))))))
171          (let ((,var nil))
172            (declare (ignorable ,var))
173            ,@decls
174            ,result-form)))))
175
176 (defmacro-mundanely do-all-symbols ((var &optional
177                                          result-form)
178                                     &body body-decls)
179   #!+sb-doc
180   "DO-ALL-SYMBOLS (VAR [RESULT-FORM]) {DECLARATION}* {TAG | FORM}*
181    Executes the FORMs once for each symbol in every package with VAR bound
182    to the current symbol."
183   (multiple-value-bind (body decls)
184       (parse-body body-decls :doc-string-allowed nil)
185     (let ((flet-name (gensym "DO-SYMBOLS-")))
186       `(block nil
187          (flet ((,flet-name (,var)
188                   ,@decls
189                   (tagbody ,@body)))
190            (dolist (package (list-all-packages))
191              (flet ((iterate-over-hash-table (table)
192                       (let ((hash-vec (package-hashtable-hash table))
193                             (sym-vec (package-hashtable-table table)))
194                         (dotimes (i (length sym-vec))
195                           (when (>= (aref hash-vec i) 2)
196                             (,flet-name (aref sym-vec i)))))))
197                (iterate-over-hash-table (package-internal-symbols package))
198                (iterate-over-hash-table (package-external-symbols package)))))
199          (let ((,var nil))
200            (declare (ignorable ,var))
201            ,@decls
202            ,result-form)))))
203 \f
204 ;;;; WITH-PACKAGE-ITERATOR
205
206 (defmacro-mundanely with-package-iterator ((mname package-list
207                                                   &rest symbol-types)
208                                            &body body)
209   #!+sb-doc
210   "Within the lexical scope of the body forms, MNAME is defined via macrolet
211 such that successive invocations of (MNAME) will return the symbols, one by
212 one, from the packages in PACKAGE-LIST. SYMBOL-TYPES may be any
213 of :INHERITED :EXTERNAL :INTERNAL."
214   (let* ((packages (gensym))
215          (these-packages (gensym))
216          (ordered-types (let ((res nil))
217                           (dolist (kind '(:inherited :external :internal)
218                                         res)
219                             (when (member kind symbol-types)
220                               (push kind res)))))  ; Order SYMBOL-TYPES.
221          (counter (gensym))
222          (kind (gensym))
223          (hash-vector (gensym))
224          (vector (gensym))
225          (package-use-list (gensym))
226          (init-macro (gensym))
227          (end-test-macro (gensym))
228          (real-symbol-p (gensym))
229          (inherited-symbol-p (gensym))
230          (BLOCK (gensym)))
231     `(let* ((,these-packages ,package-list)
232             (,packages `,(mapcar (lambda (package)
233                                    (if (packagep package)
234                                        package
235                                        ;; Maybe FIND-PACKAGE-OR-DIE?
236                                        (or (find-package package)
237                                            (error 'simple-package-error
238                                                   ;; could be a character
239                                                   :package (string package)
240                                                   :format-control "~@<~S does not name a package ~:>"
241                                                   :format-arguments (list package)))))
242                                  (if (consp ,these-packages)
243                                      ,these-packages
244                                      (list ,these-packages))))
245             (,counter nil)
246             (,kind (car ,packages))
247             (,hash-vector nil)
248             (,vector nil)
249             (,package-use-list nil))
250        ,(if (member :inherited ordered-types)
251             `(setf ,package-use-list (package-%use-list (car ,packages)))
252             `(declare (ignore ,package-use-list)))
253        (macrolet ((,init-macro (next-kind)
254          (declare (optimize (inhibit-warnings 3)))
255          (let ((symbols (gensym)))
256            `(progn
257               (setf ,',kind ,next-kind)
258               (setf ,',counter nil)
259               ,(case next-kind
260                  (:internal
261                   `(let ((,symbols (package-internal-symbols
262                                     (car ,',packages))))
263                      (when ,symbols
264                        (setf ,',vector (package-hashtable-table ,symbols))
265                        (setf ,',hash-vector
266                              (package-hashtable-hash ,symbols)))))
267                  (:external
268                   `(let ((,symbols (package-external-symbols
269                                     (car ,',packages))))
270                      (when ,symbols
271                        (setf ,',vector (package-hashtable-table ,symbols))
272                        (setf ,',hash-vector
273                              (package-hashtable-hash ,symbols)))))
274                  (:inherited
275                   `(let ((,symbols (and ,',package-use-list
276                                         (package-external-symbols
277                                          (car ,',package-use-list)))))
278                      (when ,symbols
279                        (setf ,',vector (package-hashtable-table ,symbols))
280                        (setf ,',hash-vector
281                              (package-hashtable-hash ,symbols)))))))))
282                   (,end-test-macro (this-kind)
283                      `,(let ((next-kind (cadr (member this-kind
284                                                       ',ordered-types))))
285                          (if next-kind
286                              `(,',init-macro ,next-kind)
287                              `(if (endp (setf ,',packages (cdr ,',packages)))
288                                   (return-from ,',BLOCK)
289                                   (,',init-macro ,(car ',ordered-types)))))))
290          (when ,packages
291            ,(when (null symbol-types)
292               (error 'simple-program-error
293                      :format-control
294                      "At least one of :INTERNAL, :EXTERNAL, or ~
295                       :INHERITED must be supplied."))
296            ,(dolist (symbol symbol-types)
297               (unless (member symbol '(:internal :external :inherited))
298                 (error 'program-error
299                        :format-control
300                        "~S is not one of :INTERNAL, :EXTERNAL, or :INHERITED."
301                        :format-argument symbol)))
302            (,init-macro ,(car ordered-types))
303            (flet ((,real-symbol-p (number)
304                     (> number 1)))
305              (macrolet ((,mname ()
306               (declare (optimize (inhibit-warnings 3)))
307               `(block ,',BLOCK
308                  (loop
309                    (case ,',kind
310                      ,@(when (member :internal ',ordered-types)
311                          `((:internal
312                             (setf ,',counter
313                                   (position-if #',',real-symbol-p
314                                                (the hash-vector ,',hash-vector)
315                                                :start (if ,',counter
316                                                           (1+ ,',counter)
317                                                           0)))
318                             (if ,',counter
319                                 (return-from ,',BLOCK
320                                  (values t (svref ,',vector ,',counter)
321                                          ,',kind (car ,',packages)))
322                                 (,',end-test-macro :internal)))))
323                      ,@(when (member :external ',ordered-types)
324                          `((:external
325                             (setf ,',counter
326                                   (position-if #',',real-symbol-p
327                                                (the hash-vector ,',hash-vector)
328                                                :start (if ,',counter
329                                                           (1+ ,',counter)
330                                                           0)))
331                             (if ,',counter
332                                 (return-from ,',BLOCK
333                                  (values t (svref ,',vector ,',counter)
334                                          ,',kind (car ,',packages)))
335                                 (,',end-test-macro :external)))))
336                      ,@(when (member :inherited ',ordered-types)
337                          `((:inherited
338                             (flet ((,',inherited-symbol-p (number)
339                                      (when (,',real-symbol-p number)
340                                        (let* ((p (position
341                                                   number
342                                                   (the hash-vector
343                                                     ,',hash-vector)
344                                                   :start (if ,',counter
345                                                              (1+ ,',counter)
346                                                              0)))
347                                               (s (svref ,',vector p)))
348                                          (eql (nth-value
349                                                1 (find-symbol
350                                                   (symbol-name s)
351                                                   (car ,',packages)))
352                                               :inherited)))))
353                               (setf ,',counter
354                                     (when ,',hash-vector
355                                       (position-if #',',inherited-symbol-p
356                                                    (the hash-vector
357                                                      ,',hash-vector)
358                                                    :start (if ,',counter
359                                                               (1+ ,',counter)
360                                                               0)))))
361                             (cond (,',counter
362                                    (return-from
363                                     ,',BLOCK
364                                     (values t (svref ,',vector ,',counter)
365                                             ,',kind (car ,',packages))
366                                     ))
367                                   (t
368                                    (setf ,',package-use-list
369                                          (cdr ,',package-use-list))
370                                    (cond ((endp ,',package-use-list)
371                                           (setf ,',packages (cdr ,',packages))
372                                           (when (endp ,',packages)
373                                             (return-from ,',BLOCK))
374                                           (setf ,',package-use-list
375                                                 (package-%use-list
376                                                  (car ,',packages)))
377                                           (,',init-macro ,(car
378                                                            ',ordered-types)))
379                                          (t (,',init-macro :inherited)
380                                             (setf ,',counter nil)))))))))))))
381                ,@body)))))))