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

Last change on this file was 16685, checked in by rme, 4 years ago

Update copyright/license headers in files.

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