source: branches/1.2/devel/source/level-1/l1-symhash.lisp @ 8123

Last change on this file since 8123 was 6196, checked in by gb, 13 years ago

Extra slot (for intern hook) in PACKAGE object.

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