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

Last change on this file since 12219 was 10811, checked in by gz, 11 years ago

Propagate r10799 to trunk

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