source: trunk/source/level-1/l1-symhash.lisp @ 14376

Last change on this file since 14376 was 13975, checked in by gb, 9 years ago

Fix typo in DECLAIM.

  • Property svn:eol-style set to native
  • Property svn:keywords set to Author Date Id Revision
File size: 38.8 KB
Line 
1;;;-*-Mode: LISP; Package: CCL -*-
2;;;
3;;;   Copyright (C) 2009 Clozure Associates
4;;;   Copyright (C) 1994-2001 Digitool, Inc
5;;;   This file is part of Clozure CL. 
6;;;
7;;;   Clozure CL is licensed under the terms of the Lisp Lesser GNU Public
8;;;   License , known as the LLGPL and distributed with Clozure CL as the
9;;;   file "LICENSE".  The LLGPL consists of a preamble and the LGPL,
10;;;   which is distributed with Clozure CL as the file "LGPL".  Where these
11;;;   conflict, the preamble takes precedence. 
12;;;
13;;;   Clozure CL is referenced in the preamble as the "LIBRARY."
14;;;
15;;;   The LLGPL is also available online at
16;;;   http://opensource.franz.com/preamble.html
17
18(in-package "CCL")
19
20(declaim (special %all-packages%))
21(declaim (list %all-packages%))
22(declaim (type package *package*))
23
24
25
26(defun dereference-base-string-or-symbol (s)
27  (if (symbolp s)
28    (dereference-base-string (symbol-name s))
29    (dereference-base-string s)))
30
31(defun dereference-base-string-or-symbol-or-char (s)
32  (if (typep s 'character)
33    (values (make-string 1 :element-type 'base-char :initial-element s) 0 1)
34    (dereference-base-string-or-symbol s)))
35
36
37(defun %string= (string1 string2 start1 end1)
38  (declare (optimize (speed 3) (safety 0))
39           (fixnum start1 end1))
40  (when (eq (length string2) (%i- end1 start1))
41    (do* ((i start1 (1+ i))
42          (j 0 (1+ j)))
43         ((>= i end1))
44      (declare (fixnum i j))
45      (when (not (eq (%scharcode string1 i)(%scharcode string2 j)))
46        (return-from %string= nil)))
47    t))
48
49
50
51
52(defun export (sym-or-syms &optional (package *package*))
53  "Exports SYMBOLS from PACKAGE, checking that no name conflicts result."
54  (setq package (pkg-arg package))
55  (if (atom sym-or-syms)
56    (let* ((temp (cons sym-or-syms nil)))
57      (declare (dynamic-extent temp))
58      (export temp package))
59    (progn
60      (dolist (sym sym-or-syms)
61        (unless (symbolp sym) (return (setq sym-or-syms  (mapcar #'(lambda (s) (require-type s 'symbol)) sym-or-syms)))))
62      ;; First, see if any packages used by the package being
63      ;; "exported from" already contain a distinct non-shadowing
64      ;; symbol that conflicts with one of those that we're trying to
65      ;; export.
66      (let* ((conflicts (check-export-conflicts sym-or-syms package)))
67        (if conflicts
68          (progn 
69            (resolve-export-conflicts conflicts package)
70            (export sym-or-syms package))
71          (let* ((missing nil) (need-import nil))
72            (dolist (s sym-or-syms) 
73              (multiple-value-bind (foundsym foundp) (%findsym (symbol-name s) package)
74                (if (not (and foundp (eq s foundsym)))
75                  (push s missing)
76                  (if (eq foundp :inherited)
77                    (push s need-import)))))
78            (when missing
79              (cerror "Import missing symbols before exporting them from ~S."
80                      'export-requires-import
81                      :package  package
82                      :to-be-imported missing)
83              (import missing package))
84            (if need-import (import need-import package))
85            ; Can't lose now: symbols are all directly present in package.
86            ; Ensure that they're all external; do so with interrupts disabled
87            (without-interrupts
88             (let* ((etab (pkg.etab package))
89                    (ivec (car (pkg.itab package))))
90               (dolist (s sym-or-syms t)
91                 (multiple-value-bind (foundsym foundp internal-offset)
92                                      (%findsym (symbol-name s) package)
93                   (when (eq foundp :internal)
94                     (setf (%svref ivec internal-offset) (package-deleted-marker))
95                     (let* ((pname (symbol-name foundsym)))
96                       (%htab-add-symbol foundsym etab (nth-value 2 (%get-htab-symbol pname (length pname) etab)))))))))))))))
97
98(defun check-export-conflicts (symbols package)
99  (let* ((conflicts nil))
100    (with-package-lock (package)
101      (dolist (user (pkg.used-by package) conflicts)
102        (with-package-lock (user)
103          (dolist (s symbols)
104            (multiple-value-bind (foundsym foundp) (%findsym (symbol-name s) user)
105              (if (and foundp (neq foundsym s) (not (memq foundsym (pkg.shadowed user))))
106                (push (list (eq foundp :inherited) s user foundsym) conflicts)))))))))
107 
108
109
110(defun keywordp (x)
111  "Return true if Object is a symbol in the \"KEYWORD\" package."
112  (and (symbolp x) (eq (symbol-package x) *keyword-package*)))
113
114;;;No type/range checking.  For DO-SYMBOLS and friends.
115(defun %htab-symbol (array index)
116  (let* ((sym (%svref array index)))
117    (if (symbolp sym)
118      (values (%symptr->symbol sym) t)
119      (values nil nil))))
120
121(defun find-all-symbols (name)
122  "Return a list of all symbols in the system having the specified name."
123  (let* ((syms ())
124         (pname (ensure-simple-string (string name)))
125         (len (length pname)))
126    (with-package-list-read-lock
127        (dolist (p %all-packages% syms)
128          (with-package-lock (p)
129            (multiple-value-bind (sym foundp) (%find-package-symbol pname p len)
130              (if foundp (pushnew sym syms :test #'eq))))))))
131     
132
133(defun list-all-packages ()
134  "Return a list of all existing packages."
135  (with-package-list-read-lock (copy-list %all-packages%)))
136
137(defun rename-package (package new-name &optional new-nicknames)
138  "Changes the name and nicknames for a package."
139  (setq package (pkg-arg package)
140        new-name (ensure-simple-string (string new-name)))
141  (with-package-lock (package)
142    (let* ((names (pkg.names package)))
143      (declare (type cons names))
144      (dolist (n names)
145        (let* ((ref (register-package-ref n)))
146          (setf (package-ref.pkg ref) nil)))
147      (rplaca names (new-package-name new-name package))
148      (let* ((ref (register-package-ref (car names))))
149        (setf (package-ref.pkg ref) package))
150      (rplacd names nil))
151    (%add-nicknames new-nicknames package)))
152
153;;; Someday, this should become LISP:IN-PACKAGE.
154(defun old-in-package (name &key 
155                        nicknames 
156                        (use nil use-p) 
157                        (internal-size 60)
158                        (external-size 10))
159  (let ((pkg (find-package (setq name (string name)))))
160    (if pkg
161      (progn
162        (use-package use pkg)
163        (%add-nicknames nicknames pkg))
164      (setq pkg
165            (make-package name 
166                          :nicknames nicknames
167                          :use (if use-p use *make-package-use-defaults*)
168                          :internal-size internal-size
169                          :external-size external-size)))
170    (setq *package* pkg)))
171
172
173(defvar *make-package-use-defaults* '("COMMON-LISP" "CCL"))
174
175;;; On principle, this should get exported here.  Unfortunately, we
176;;; can't execute calls to export quite yet.
177
178
179(defun make-package (name &key
180                          nicknames
181                          (use *make-package-use-defaults*)
182                          (internal-size 60)
183                          (external-size 10))
184  "Make a new package having the specified NAME, NICKNAMES, and
185  USE list. :INTERNAL-SYMBOLS and :EXTERNAL-SYMBOLS are
186  estimates for the number of internal and external symbols which
187  will ultimately be present in the package. The default value of
188  USE is implementation-dependent, and in this implementation
189  it is NIL."
190  (setq internal-size (require-type internal-size 'fixnum)
191        external-size (require-type external-size 'fixnum))
192  (let* ((pkg-name (new-package-name name))
193         (pkg (gvector :package 
194                       (%new-package-hashtable internal-size)
195                       (%new-package-hashtable external-size)
196                       nil
197                       nil
198                       (list pkg-name)
199                       nil
200                       (make-read-write-lock)
201                       nil)))
202    (let* ((ref (register-package-ref pkg-name)))
203      (setf (package-ref.pkg ref) pkg))
204    (use-package use pkg)
205    (%add-nicknames nicknames pkg)
206    (with-package-list-write-lock
207        (push pkg %all-packages%))
208    pkg))
209
210(defun new-package-name (name &optional package)
211  (do* ((prompt "Enter package name to use instead of ~S ."))
212       ((let* ((found (find-package (setq name (ensure-simple-string (string name))))))
213          (or (not found)
214              (eq package found)))
215        name)
216    (restart-case (%error "Package name ~S is already in use." (list name) (%get-frame-ptr))
217      (new-name (new-name)
218                :report (lambda (s) (format s prompt name))
219                :interactive 
220                (lambda () 
221                  (list (block nil (catch-cancel (return (get-string-from-user
222                                                          (format nil prompt name))))
223                               nil)))
224                (if new-name (setq name new-name))))))
225       
226(defun new-package-nickname (name package)
227  (setq name (string name))
228  (let* ((other (find-package name))
229         (prompt "Enter package name to use instead of ~S ."))
230    (if other
231      (unless (eq other package)
232        (let* ((conflict-with-proper-name (string= (package-name other) name))
233               (condition (make-condition 'package-name-conflict-error
234                                          :package package
235                                          :format-arguments (list name other)
236                                          :format-control (%str-cat "~S is already "
237                                                                   (if conflict-with-proper-name
238                                                                     "the "
239                                                                     "a nick")
240                                                                   "name of ~S."))))
241          (restart-case (%error condition nil (%get-frame-ptr))
242            (continue ()
243                      :report (lambda (s) (format s "Don't make ~S a nickname for ~S" name package)))
244            (new-name (new-name)
245                      :report (lambda (s) (format s prompt name))
246                      :interactive 
247                      (lambda () 
248                        (list (block nil (catch-cancel (return (get-string-from-user
249                                                                (format nil prompt name))))
250                                     nil)))
251                      (if new-name (new-package-nickname new-name package)))
252            (remove-conflicting-nickname ()
253                                         :report (lambda (s)
254                                                   (format s "Remove conflicting-nickname ~S from ~S." name other))
255                                         :test (lambda (&rest ignore) (declare (ignore ignore)) (not conflict-with-proper-name))
256                                         (rplacd (pkg.names other)
257                                                 (delete name (cdr (pkg.names other)) :test #'string=))
258                                         name))))
259      name)))
260
261(defun %add-nicknames (nicknames package)
262  (let ((names (pkg.names package)))
263    (dolist (name nicknames package)
264      (let* ((ok-name (new-package-nickname name package)))
265        (when ok-name
266          (let* ((ref (register-package-ref ok-name)))
267            (setf (package-ref.pkg ref) package)
268            (push ok-name (cdr names))))))))
269
270(defun find-symbol (string &optional package)
271  "Return the symbol named STRING in PACKAGE. If such a symbol is found
272  then the second value is :INTERNAL, :EXTERNAL or :INHERITED to indicate
273  how the symbol is accessible. If no symbol is found then both values
274  are NIL."
275  (multiple-value-bind (sym flag)
276      (%findsym (ensure-simple-string string) (pkg-arg (or package *package*)))
277    (values sym flag)))
278
279(defun %pkg-ref-find-symbol (string ref)
280  (multiple-value-bind (sym flag)
281      (%findsym (ensure-simple-string string)
282                (or (package-ref.pkg ref)
283                    (%kernel-restart $xnopkg (package-ref.name ref))))
284    (values sym flag)))
285   
286;;; Somewhat saner interface to %find-symbol
287(defun %findsym (string package)
288  (%find-symbol string (length string) package))
289
290(eval-when (:compile-toplevel)
291  (declaim (inline %intern)))
292
293(defun %intern (str package)
294  (setq str (ensure-simple-string str))
295  (with-package-lock (package)
296   (multiple-value-bind (symbol where internal-offset external-offset) 
297                        (%find-symbol str (length str) package)
298     (if where
299       (values symbol where)
300       (values (%add-symbol str package internal-offset external-offset) nil)))))
301
302
303(defun intern (str &optional (package *package*))
304  "Return a symbol in PACKAGE having the specified NAME, creating it
305  if necessary."
306  (%intern str (pkg-arg package)))
307
308(defun %pkg-ref-intern (str ref)
309  (%intern str (or (package-ref.pkg ref)
310                   (%kernel-restart $xnopkg (package-ref.name ref)))))
311
312(defun unintern (symbol &optional (package *package*))
313  "Makes SYMBOL no longer present in PACKAGE. If SYMBOL was present
314  then T is returned, otherwise NIL. If PACKAGE is SYMBOL's home
315  package, then it is made uninterned."
316  (setq package (pkg-arg package))
317  (setq symbol (require-type symbol 'symbol))
318  (multiple-value-bind (foundsym table index) (%find-package-symbol (symbol-name symbol) package)
319    (when (and table (eq symbol foundsym))
320      (when (memq symbol (pkg.shadowed package))
321        ;; A conflict is possible if more than one distinct
322        ;; similarly-named external symbols exist in the packages used
323        ;; by this one.  Grovel around looking for such conflicts; if
324        ;; any are found, signal an error (via %kernel-restart) which
325        ;; offers to either shadowing-import one of the conflicting
326        ;; symbols into the current package or abandon the attempt to
327        ;; unintern in the first place.
328        (let* ((first nil)
329               (first-p nil)
330               (name (symbol-name symbol))
331               (len (length name))
332               (others nil))
333          (declare (dynamic-extent first))
334          (with-package-lock (package)
335            (dolist (pkg (pkg.used package))
336              (with-package-lock (pkg)
337                (multiple-value-bind (found conflicting-sym) (%get-htab-symbol name len (pkg.etab pkg))
338                  (when found
339                    (if first-p
340                      (unless (or (eq conflicting-sym first)
341                                  (memq conflicting-sym others))
342                        (push conflicting-sym others))
343                      (setq first-p t first conflicting-sym)))))))
344          (when others
345            ;;If this returns, it will have somehow fixed things.
346            (return-from unintern (%kernel-restart $xunintc symbol package (cons first others)))))
347        ;; No conflicts found, but symbol was on shadowing-symbols list.  Remove it atomically.
348        (do* ((head (cons nil (pkg.shadowed package)))
349              (prev head next)
350              (next (cdr prev) (cdr next)))
351             ((null next))              ; Should never happen
352          (declare (dynamic-extent head) 
353                   (list head prev next)
354                   (optimize (speed 3) (safety 0)))
355          (when (eq (car next) symbol)
356            (setf (cdr prev) (cdr next)
357                  (pkg.shadowed package) (cdr head))
358            (return))))
359      ;; Now remove the symbol from package; if package was its home
360      ;; package, set its package to NIL.  If we get here, the "table"
361      ;; and "index" values returned above are still valid.
362      (%svset (car table) index (package-deleted-marker))
363      (when (eq (symbol-package symbol) package)
364        (%set-symbol-package symbol nil))
365      t)))
366
367(defun import-1 (package sym)
368  (multiple-value-bind (conflicting-sym type internal-offset external-offset) (%findsym (symbol-name sym) package)
369    (if (and type (neq conflicting-sym sym))
370      (let* ((external-p (eq type :inherited))
371             (condition (make-condition 'import-conflict-error 
372                                        :package package
373                                        :imported-sym sym
374                                        :conflicting-sym conflicting-sym
375                                        :conflict-external external-p)))
376        (restart-case (error condition)
377          (continue ()
378                    :report (lambda (s) (format s "Ignore attempt to import ~S to ~S." sym package)))
379          (resolve-conflict ()
380                            :report (lambda (s)
381                                      (let* ((package-name (package-name package)))
382                                        (if external-p 
383                                          (format s "~A ~s in package ~s ." 'shadowing-import sym package-name)
384                                          (format s "~A ~s from package ~s ." 'unintern conflicting-sym package-name))))
385                            (if external-p 
386                              (shadowing-import-1 package sym)
387                              (progn
388                                (unintern conflicting-sym package)
389                                (import-1 package sym))))))
390      (unless (or (eq type :external) (eq type :internal))
391        (%insert-symbol sym package internal-offset external-offset)))))
392
393
394(defun import (sym-or-syms &optional package)
395  "Make SYMBOLS accessible as internal symbols in PACKAGE. If a symbol
396  is already accessible then it has no effect. If a name conflict
397  would result from the importation, then a correctable error is signalled."
398  (setq package (pkg-arg (or package *package*)))
399  (if (listp sym-or-syms)
400    (dolist (sym sym-or-syms)
401      (import-1 package sym))
402    (import-1 package sym-or-syms))
403  t)
404
405(defun shadow-1 (package sym)
406  (let* ((pname (ensure-simple-string (string sym)))
407         (len (length pname)))
408    (without-interrupts
409     (multiple-value-bind (symbol where internal-idx external-idx) (%find-symbol pname len package)
410       (if (or (eq where :internal) (eq where :external))
411         (pushnew symbol (pkg.shadowed package))
412         (push (%add-symbol pname package internal-idx external-idx) (pkg.shadowed package)))))
413    nil))
414
415(defun shadow (sym-or-symbols-or-string-or-strings &optional package)
416  "Make an internal symbol in PACKAGE with the same name as each of
417  the specified SYMBOLS. If a symbol with the given name is already
418  present in PACKAGE, then the existing symbol is placed in the
419  shadowing symbols list if it is not already present."
420  (setq package (pkg-arg (or package *package*)))
421  (if (listp sym-or-symbols-or-string-or-strings)
422    (dolist (s sym-or-symbols-or-string-or-strings)
423      (shadow-1 package s))
424    (shadow-1 package sym-or-symbols-or-string-or-strings))
425  t)
426
427(defun unexport (sym-or-symbols &optional package)
428  "Makes SYMBOLS no longer exported from PACKAGE."
429  (setq package (pkg-arg (or package *package*)))
430  (if (listp sym-or-symbols)
431    (dolist (sym sym-or-symbols)
432      (unexport-1 package sym))
433    (unexport-1 package sym-or-symbols))
434  t)
435
436(defun unexport-1 (package sym)
437  (when (eq package *keyword-package*)
438    (error "Can't unexport ~S from ~S ." sym package))
439  (multiple-value-bind (foundsym foundp internal-offset external-offset)
440                       (%findsym (symbol-name sym) package)
441    (unless foundp
442      (error 'symbol-name-not-accessible
443             :symbol-name (symbol-name sym)
444             :package package))
445    (when (eq foundp :external)
446      (let* ((evec (car (pkg.etab package)))
447             (itab (pkg.itab package))
448             (ivec (car itab))
449             (icount&limit (cdr itab)))
450        (declare (type cons itab icount&limit))
451        (setf (svref evec external-offset) (package-deleted-marker))
452        (setf (svref ivec internal-offset) (%symbol->symptr foundsym))
453        (if (eql (setf (car icount&limit)
454                       (the fixnum (1+ (the fixnum (car icount&limit)))))
455                 (the fixnum (cdr icount&limit)))
456          (%resize-htab itab)))))
457  nil)
458
459;;; Both args must be packages.
460(defun %use-package-conflict-check (using-package package-to-use)
461  (let ((already-used (pkg.used using-package)))
462    (unless (or (eq using-package package-to-use)
463                (memq package-to-use already-used))
464      ;; There are two types of conflict that can potentially occur:
465      ;;   1) An external symbol in the package being used conflicts
466      ;;        with a symbol present in the using package
467      ;;   2) An external symbol in the package being used conflicts
468      ;;        with an external symbol in some other package that's
469      ;;        already used.
470      (let* ((ext-ext-conflicts nil)
471             (used-using-conflicts nil)
472             (shadowed-in-using (pkg.shadowed using-package))
473             (to-use-etab (pkg.etab package-to-use)))
474        (without-interrupts
475         (dolist (already already-used)
476           (let ((user (if (memq package-to-use (pkg.used-by already))
477                         package-to-use
478                         (if (memq package-to-use (pkg.used already))
479                           already))))
480             (if user
481               (let* ((used (if (eq user package-to-use) already package-to-use))
482                      (user-etab (pkg.etab user))
483                      (used-etab (pkg.etab used)))
484                 (dolist (shadow (pkg.shadowed user))
485                   (let ((sname (symbol-name shadow)))
486                     (unless (member sname shadowed-in-using :test #'string=)
487                       (let ((len (length sname)))
488                         (when (%get-htab-symbol sname len user-etab)   ; external in user
489                           (multiple-value-bind (external-in-used used-sym) (%get-htab-symbol sname len used-etab)
490                             (when (and external-in-used (neq used-sym shadow))
491                               (push (list shadow used-sym) ext-ext-conflicts)))))))))
492               ;; Remember what we're doing here ?
493               ;; Neither of the two packages use the other.  Iterate
494               ;; over the external symbols in the package that has
495               ;; the fewest external symbols and note conflicts with
496               ;; external symbols in the other package.
497               (let* ((smaller (if (%i< (%cadr to-use-etab) (%cadr (pkg.etab already)))
498                                 package-to-use
499                                 already))
500                      (larger (if (eq smaller package-to-use) already package-to-use))
501                      (larger-etab (pkg.etab larger))
502                      (smaller-v (%car (pkg.etab smaller))))
503                 (dotimes (i (uvsize smaller-v))
504                   (declare (fixnum i))
505                   (let ((symptr (%svref smaller-v i)))
506                     (when (symbolp symptr)
507                       (let* ((sym (%symptr->symbol symptr))
508                              (symname (symbol-name sym)))
509                         (unless (member symname shadowed-in-using :test #'string=)
510                           (multiple-value-bind (found-in-larger sym-in-larger)
511                                                (%get-htab-symbol symname (length symname) larger-etab)
512                             (when (and found-in-larger (neq sym-in-larger sym))
513                               (push (list sym sym-in-larger) ext-ext-conflicts))))))))))))
514         ;; Now see if any non-shadowed, directly present symbols in
515         ;; the using package conflicts with an external symbol in the
516         ;; package being used.  There are two ways of doing this; one
517         ;; of them -may- be much faster than the other.
518         (let* ((to-use-etab-size (%cadr to-use-etab))
519                (present-symbols-size (%i+ (%cadr (pkg.itab using-package)) (%cadr (pkg.etab using-package)))))
520           (unless (eql 0 present-symbols-size)
521             (if (%i< present-symbols-size to-use-etab-size)
522               ;; Faster to look up each present symbol in to-use-etab.
523               (let ((htabvs (list (%car (pkg.etab using-package)) (%car (pkg.itab using-package)))))
524                 (declare (dynamic-extent htabvs))
525                 (dolist (v htabvs)
526                   (dotimes (i (the fixnum (uvsize v)))
527                     (declare (fixnum i))
528                     (let ((symptr (%svref v i)))
529                       (when (symbolp symptr)
530                         (let* ((sym (%symptr->symbol symptr)))
531                           (unless (memq sym shadowed-in-using)
532                             (let* ((name (symbol-name symptr)))
533                               (multiple-value-bind (found-p to-use-sym) (%get-htab-symbol name (length name) to-use-etab)
534                                 (when (and found-p (neq to-use-sym sym))
535                                   (push (list sym to-use-sym) used-using-conflicts)))))))))))
536               ;; See if any external symbol present in the package
537               ;; being used conflicts with any symbol present in the
538               ;; using package.
539               (let ((v (%car to-use-etab)))
540                 (dotimes (i (uvsize v))
541                   (declare (fixnum i))
542                   (let ((symptr (%svref v i)))
543                     (when (symbolp symptr)
544                       (let* ((sym (%symptr->symbol symptr)))
545                         (multiple-value-bind (using-sym found-p) (%find-package-symbol (symbol-name sym) using-package)
546                           (when (and found-p
547                                      (neq sym using-sym)
548                                      (not (memq using-sym shadowed-in-using)))
549                             (push (list using-sym sym) used-using-conflicts))))))))))))
550        (values ext-ext-conflicts used-using-conflicts)))))
551
552(defun use-package-1 (using-package package-to-use)
553  (if (eq (setq package-to-use (pkg-arg package-to-use))
554          *keyword-package*)
555    (error "~S can't use ~S." using-package package-to-use))
556  (do* ((used-external-conflicts nil)
557        (used-using-conflicts nil))
558       ((and (null (multiple-value-setq (used-external-conflicts used-using-conflicts)
559                     (%use-package-conflict-check using-package package-to-use)))
560             (null used-using-conflicts)))
561    (if used-external-conflicts
562      (%kernel-restart $xusecX package-to-use using-package used-external-conflicts)
563      (if used-using-conflicts
564        (%kernel-restart $xusec package-to-use using-package used-using-conflicts))))
565  (unless (memq using-package (pkg.used-by package-to-use))   ;  Not already used in break loop/restart, etc.
566    (push using-package (pkg.used-by package-to-use))
567    (push package-to-use (pkg.used using-package))))
568
569(defun use-package (packages-to-use &optional package)
570  "Add all the PACKAGES-TO-USE to the use list for PACKAGE so that
571  the external symbols of the used packages are accessible as internal
572  symbols in PACKAGE."
573  (setq package (pkg-arg (or package *package*)))
574  (if (listp packages-to-use)
575    (dolist (to-use packages-to-use)
576      (use-package-1 package to-use))
577    (use-package-1 package packages-to-use))
578  t)
579
580(defun shadowing-import-1 (package sym)
581  (let* ((pname (symbol-name sym))
582         (len (length pname))
583         (need-add t))
584    (without-interrupts
585     (multiple-value-bind (othersym htab offset) (%find-package-symbol pname package)
586       (if htab
587         (if (eq othersym sym)
588           (setq need-add nil)
589           (progn                       ; Delete conflicting symbol
590             (if (eq (symbol-package othersym) package)
591               (%set-symbol-package othersym nil))
592             (setf (%svref (car htab) offset) (package-deleted-marker))
593             (setf (pkg.shadowed package) (delete othersym (pkg.shadowed package) :test #'eq)))))
594       (if need-add                   ; No symbols with same pname; intern & shadow
595         (multiple-value-bind (xsym foundp internal-offset external-offset) 
596                              (%find-symbol pname len package)
597           (declare (ignore xsym foundp))
598           (%insert-symbol sym package internal-offset external-offset)))
599       (pushnew sym (pkg.shadowed package))
600       nil))))
601
602(defun shadowing-import (sym-or-syms &optional (package *package*))
603  "Import SYMBOLS into package, disregarding any name conflict. If
604  a symbol of the same name is present, then it is uninterned."
605  (setq package (pkg-arg package))
606  (if (listp sym-or-syms)
607    (dolist (sym sym-or-syms)
608      (shadowing-import-1 package sym))
609    (shadowing-import-1 package sym-or-syms))
610  t)
611
612(defun unuse-package (packages-to-unuse &optional package)
613  "Remove PACKAGES-TO-UNUSE from the USE list for PACKAGE."
614  (let ((p (pkg-arg (or package *package*))))
615    (flet ((unuse-one-package (unuse)
616            (setq unuse (pkg-arg unuse))
617            (setf (pkg.used p) (nremove unuse (pkg.used p))
618                  (pkg.used-by unuse) (nremove p (pkg.used-by unuse)))))
619      (declare (dynamic-extent #'unuse-one-package))
620      (if (listp packages-to-unuse)
621        (dolist (u packages-to-unuse) (unuse-one-package u))
622        (unuse-one-package packages-to-unuse))
623      t)))
624
625(defun delete-package (package)
626  "Delete the package designated by PACKAGE-DESIGNATOR from the package
627  system data structures."
628  (unless (packagep package)
629    (setq package (or (find-package package)
630                      (progn
631                        (cerror "Do nothing" 'no-such-package :package package)
632                        (return-from delete-package nil)))))
633  (with-package-list-read-lock
634    (unless (memq package %all-packages%)
635      (return-from delete-package nil)))
636  (when (pkg.used-by package)
637    (cerror "unuse ~S" 'package-is-used-by :package package
638            :using-packages (pkg.used-by package)))
639  (while (pkg.used-by package)
640    (unuse-package package (car (pkg.used-by package))))
641  (while (pkg.used package)
642    (unuse-package (car (pkg.used package)) package))
643  (setf (pkg.shadowed package) nil)
644  (with-package-list-write-lock
645    (setq %all-packages% (nremove package %all-packages%)))
646  (dolist (n (pkg.names package))
647    (let* ((ref (register-package-ref n)))
648      (setf (package-ref.pkg ref) nil)))
649  (setf (pkg.names package) nil)
650  (let* ((ivec (car (pkg.itab package)))
651         (evec (car (pkg.etab package)))
652         (deleted (package-deleted-marker)))
653    (dotimes (i (the fixnum (length ivec)))
654      (let* ((sym (%svref ivec i)))
655        (setf (%svref ivec i) deleted)          ; in case it's in STATIC space
656        (when (symbolp sym)
657          (if (eq (symbol-package sym) package)
658            (%set-symbol-package sym nil)))))
659    (dotimes (i (the fixnum (length evec)))
660      (let* ((sym (%svref evec i)))
661        (setf (%svref evec i) deleted)          ; in case it's in STATIC space
662        (when (symbolp sym)
663          (if (eq (symbol-package sym) package)
664            (%set-symbol-package sym nil))))))
665  (let ((itab (pkg.itab package)) (etab (pkg.etab package)) (v '#(nil nil nil)))
666    (%rplaca itab v) (%rplaca etab v)
667    (%rplaca (%cdr itab) 0) (%rplaca (%cdr etab) 0)
668    (%rplacd (%cdr itab) #x4000) (%rplacd (%cdr etab) #x4000))
669  t)
670
671(defun %find-package-symbol (string package &optional (len (length string)))
672  (let* ((etab (pkg.etab package))
673         (itab (pkg.itab package)))
674    (multiple-value-bind (foundp sym offset) (%get-htab-symbol string len itab)
675      (if foundp
676        (values sym itab offset)
677        (progn
678          (multiple-value-setq (foundp sym offset)
679          (%get-htab-symbol string len etab))
680          (if foundp
681            (values sym etab offset)
682            (values nil nil nil)))))))
683
684;;;For the inspector, number of symbols in pkg.
685(defun %pkgtab-count (pkgtab)
686  (let* ((n 0))
687    (declare (fixnum n))
688    (dovector (x (pkgtab-table pkgtab) n)
689       (when (symbolp x)
690         (incf n)))))
691
692
693(defun %resize-package (pkg)
694  (%resize-htab (pkg.itab pkg))
695  (%resize-htab (pkg.etab pkg))
696  pkg)
697
698;These allow deleted packages, so can't use pkg-arg which doesn't.
699;Of course, the wonderful world of optional arguments comes in handy.
700(defun pkg-arg-allow-deleted (pkg)
701  (pkg-arg pkg t))
702
703
704(defun package-name (pkg) (%car (pkg.names (pkg-arg-allow-deleted pkg))))
705;;>> Shouldn't these copy-list their result so that the user
706;;>>  can't cause a crash through evil rplacding?
707;Of course that would make rplacding less evil, and then how would they ever learn?
708(defun package-nicknames (pkg) (%cdr (pkg.names (pkg-arg-allow-deleted pkg))))
709(defun package-use-list (pkg) (pkg.used (pkg-arg-allow-deleted pkg)))
710(defun package-used-by-list (pkg) (pkg.used-by (pkg-arg-allow-deleted pkg)))
711(defun package-shadowing-symbols (pkg) (pkg.shadowed (pkg-arg-allow-deleted pkg)))
712
713;;; This assumes that all symbol-names and package-names are strings.
714(defun %define-package (name size 
715                             external-size ; extension (may be nil.)
716                             nicknames
717                             shadow
718                             shadowing-import-from-specs
719                             use
720                             import-from-specs
721                             intern
722                             export
723                             &optional doc)
724  (if (eq use :default) (setq use *make-package-use-defaults*))
725  (let* ((pkg (find-package name)))
726    (if pkg
727      ;; Restarts could offer several ways of fixing this.
728      (unless (string= (package-name pkg) name)
729        (cerror "Redefine ~*~S"
730                "~S is already a nickname for ~S" name pkg))
731      (setq pkg (make-package name
732                              :use nil
733                              :internal-size (or size 60)
734                              :external-size (or external-size
735                                                 (max (length export) 1)))))
736    (unuse-package (package-use-list pkg) pkg)
737    (rename-package pkg name nicknames)
738    (flet ((operation-on-all-specs (function speclist)
739             (let ((to-do nil))
740               (dolist (spec speclist)
741                 (let ((from (pop spec)))
742                   (dolist (str spec)
743                     (multiple-value-bind (sym win) (find-symbol str from)
744                       (if win
745                         (push sym to-do)
746                         ; This should (maybe) be a PACKAGE-ERROR.
747                         (cerror "Ignore attempt to ~s ~s from package ~s"
748                                 "Cannot ~s ~s from package ~s" function str from))))))
749               (when to-do (funcall function to-do pkg)))))
750     
751      (dolist (sym shadow) (shadow sym pkg))
752      (operation-on-all-specs 'shadowing-import shadowing-import-from-specs)
753      (use-package use pkg)
754      (operation-on-all-specs 'import import-from-specs)
755      (dolist (str intern) (intern str pkg))
756      (when export
757        (let* ((syms nil))
758          (dolist (str export)
759            (multiple-value-bind (sym found) (find-symbol str pkg)
760              (unless found (setq sym (intern str pkg)))
761              (push sym syms)))
762          (export syms pkg)))
763      (when (and doc *save-doc-strings*)
764        (set-documentation pkg t doc))
765      pkg)))
766
767(defun %setup-pkg-iter-state (pkg-list types)
768  (collect ((steps))
769    (flet ((cons-pkg-iter-step (package type table &optional shadowed)
770             (steps (vector package type table shadowed nil nil))))
771      (let* ((pkgs (if (listp pkg-list)
772                     (mapcar #'pkg-arg pkg-list)
773                     (list (pkg-arg pkg-list)))))
774        (dolist (pkg pkgs)
775          (dolist (type types)
776            (case type
777              (:internal (cons-pkg-iter-step pkg type (pkg.itab pkg)))
778              (:external (cons-pkg-iter-step pkg type (pkg.etab pkg)))
779              (:inherited
780               (let* ((shadowed (pkg.shadowed pkg))
781                      (used (pkg.used pkg)))
782                 (dolist (u used)
783                   (cons-pkg-iter-step pkg type (pkg.etab u) shadowed)))))))))
784    (vector nil (steps))))
785
786(defun %pkg-iter-next (state)
787  (flet ((get-step ()
788           (let* ((step (pkg-iter.step state)))
789             (loop
790               (if (and step (> (pkg-iter-step.index step) 0))
791                 (return step))
792               (when (setq step (pop (pkg-iter.remaining-steps state)))
793                 (setf (pkg-iter.step state) step)
794                 (setf (pkg-iter-step.index step)
795                       (length (setf (pkg-iter-step.vector step)
796                                     (pkgtab-table  (pkg-iter-step.table step))))))
797               (unless step
798                 (return))))))
799    (loop
800      (let* ((step (get-step)))
801        (when (null step) (return))
802        (multiple-value-bind (symbol found)
803            (%htab-symbol (pkg-iter-step.vector step)
804                          (decf (pkg-iter-step.index step)))
805          (when (and found
806                     (not (member symbol (pkg-iter-step.shadowed step)
807                                  :test #'string=)))
808            (return (values t
809                            symbol
810                            (pkg-iter-step.type step)
811                            (pkg-iter-step.pkg step)))))))))
812
813
814;;; For do-symbols and with-package-iterator
815;;; string must be a simple string
816;;; package must be a package
817;;; Wouldn't it be nice if this distinguished "not found" from "found NIL" ?
818(defun %name-present-in-package-p (string package)
819  (values (%find-package-symbol string package)))
820
821;;; This is supposed to be (somewhat) like the lisp machine's MAKE-PACKAGE.
822;;; Accept and ignore some keyword arguments, accept and process some others.
823
824(defun lispm-make-package (name &key 
825                                (use *make-package-use-defaults*)
826                                nicknames
827                                ;prefix-name
828                                ;invisible
829                                (shadow nil shadow-p)
830                                (export nil export-p)
831                                (shadowing-import nil shadowing-import-p)
832                                (import nil import-p)
833                                (import-from nil import-from-p)
834                                ;relative-names
835                                ;relative-names-for-me
836                                ;size
837                                ;hash-inherited-symbols
838                                ;external-only
839                                ;include
840                                ;new-symbol-function
841                                ;colon-mode
842                                ;prefix-intern-function
843                                &allow-other-keys)
844  ;  (declare (ignore prefix-name invisible relative-names relative-names-for-me
845  ;                   size hash-inherited-symbols external-only include
846  ;                   new-symbol-function colon-mode prefix-intern-function))
847  (let ((pkg (make-package name :use NIL :nicknames nicknames)))
848    (when shadow-p (shadow shadow pkg))
849    (when shadowing-import-p (shadowing-import shadowing-import pkg))
850    (use-package use pkg)
851    (when import-from-p
852      (let ((from-pkg (pop import-from)))
853        (dolist (name import-from)
854          (multiple-value-bind (sym win) (find-symbol (string name) from-pkg)
855            (when win (import-1 pkg sym))))))
856    (when import-p (import import pkg))
857    (when export-p
858      (let* ((syms nil))
859        (dolist (name export)
860          (multiple-value-bind (sym win) (find-symbol (string name) pkg)
861            (unless win (setq sym (intern (string name) pkg)))
862            (push sym syms)))
863        (export syms pkg)))
864    pkg))
865
Note: See TracBrowser for help on using the repository browser.