;;;-*-Mode: LISP; Package: CCL -*- ;;; ;;; Copyright (C) 2009 Clozure Associates ;;; Copyright (C) 1994-2001 Digitool, Inc ;;; This file is part of Clozure CL. ;;; ;;; Clozure CL is licensed under the terms of the Lisp Lesser GNU Public ;;; License , known as the LLGPL and distributed with Clozure CL as the ;;; file "LICENSE". The LLGPL consists of a preamble and the LGPL, ;;; which is distributed with Clozure CL as the file "LGPL". Where these ;;; conflict, the preamble takes precedence. ;;; ;;; Clozure CL is referenced in the preamble as the "LIBRARY." ;;; ;;; The LLGPL is also available online at ;;; http://opensource.franz.com/preamble.html (in-package "CCL") (declaim (special %all-packages%)) (declaim (list %all-packages%)) (declaim (type package *package*)) (defun dereference-base-string-or-symbol (s) (if (symbolp s) (dereference-base-string (symbol-name s)) (dereference-base-string s))) (defun dereference-base-string-or-symbol-or-char (s) (if (typep s 'character) (values (make-string 1 :element-type 'base-char :initial-element s) 0 1) (dereference-base-string-or-symbol s))) (defun %string= (string1 string2 start1 end1) (declare (optimize (speed 3) (safety 0)) (fixnum start1 end1)) (when (eq (length string2) (%i- end1 start1)) (do* ((i start1 (1+ i)) (j 0 (1+ j))) ((>= i end1)) (declare (fixnum i j)) (when (not (eq (%scharcode string1 i)(%scharcode string2 j))) (return-from %string= nil))) t)) (defun export (sym-or-syms &optional (package *package*)) "Exports SYMBOLS from PACKAGE, checking that no name conflicts result." (setq package (pkg-arg package)) (if (atom sym-or-syms) (let* ((temp (cons sym-or-syms nil))) (declare (dynamic-extent temp)) (export temp package)) (progn (dolist (sym sym-or-syms) (unless (symbolp sym) (return (setq sym-or-syms (mapcar #'(lambda (s) (require-type s 'symbol)) sym-or-syms))))) ;; First, see if any packages used by the package being ;; "exported from" already contain a distinct non-shadowing ;; symbol that conflicts with one of those that we're trying to ;; export. (let* ((conflicts (check-export-conflicts sym-or-syms package))) (if conflicts (progn (resolve-export-conflicts conflicts package) (export sym-or-syms package)) (let* ((missing nil) (need-import nil)) (dolist (s sym-or-syms) (multiple-value-bind (foundsym foundp) (%findsym (symbol-name s) package) (if (not (and foundp (eq s foundsym))) (push s missing) (if (eq foundp :inherited) (push s need-import))))) (when missing (cerror "Import missing symbols before exporting them from ~S." 'export-requires-import :package package :to-be-imported missing) (import missing package)) (if need-import (import need-import package)) ; Can't lose now: symbols are all directly present in package. ; Ensure that they're all external; do so with interrupts disabled (without-interrupts (let* ((etab (pkg.etab package)) (ivec (car (pkg.itab package)))) (dolist (s sym-or-syms t) (multiple-value-bind (foundsym foundp internal-offset) (%findsym (symbol-name s) package) (when (eq foundp :internal) (setf (%svref ivec internal-offset) (package-deleted-marker)) (let* ((pname (symbol-name foundsym))) (%htab-add-symbol foundsym etab (nth-value 2 (%get-htab-symbol pname (length pname) etab))))))))))))))) (defun check-export-conflicts (symbols package) (let* ((conflicts nil)) (with-package-lock (package) (dolist (user (pkg.used-by package) conflicts) (with-package-lock (user) (dolist (s symbols) (multiple-value-bind (foundsym foundp) (%findsym (symbol-name s) user) (if (and foundp (neq foundsym s) (not (memq foundsym (pkg.shadowed user)))) (push (list (eq foundp :inherited) s user foundsym) conflicts))))))))) (defun keywordp (x) "Return true if Object is a symbol in the \"KEYWORD\" package." (and (symbolp x) (eq (symbol-package x) *keyword-package*))) ;;;No type/range checking. For DO-SYMBOLS and friends. (defun %htab-symbol (array index) (let* ((sym (%svref array index))) (if (symbolp sym) (values (%symptr->symbol sym) t) (values nil nil)))) (defun find-all-symbols (name) "Return a list of all symbols in the system having the specified name." (let* ((syms ()) (pname (ensure-simple-string (string name))) (len (length pname))) (with-package-list-read-lock (dolist (p %all-packages% syms) (with-package-lock (p) (multiple-value-bind (sym foundp) (%find-package-symbol pname p len) (if foundp (pushnew sym syms :test #'eq)))))))) (defun list-all-packages () "Return a list of all existing packages." (with-package-list-read-lock (copy-list %all-packages%))) (defun rename-package (package new-name &optional new-nicknames) "Changes the name and nicknames for a package." (setq package (pkg-arg package) new-name (ensure-simple-string (string new-name))) (with-package-lock (package) (let* ((names (pkg.names package))) (declare (type cons names)) (dolist (n names) (let* ((ref (register-package-ref n))) (setf (package-ref.pkg ref) nil))) (rplaca names (new-package-name new-name package)) (let* ((ref (register-package-ref (car names)))) (setf (package-ref.pkg ref) package)) (rplacd names nil)) (%add-nicknames new-nicknames package))) ;;; Someday, this should become LISP:IN-PACKAGE. (defun old-in-package (name &key nicknames (use nil use-p) (internal-size 60) (external-size 10)) (let ((pkg (find-package (setq name (string name))))) (if pkg (progn (use-package use pkg) (%add-nicknames nicknames pkg)) (setq pkg (make-package name :nicknames nicknames :use (if use-p use *make-package-use-defaults*) :internal-size internal-size :external-size external-size))) (setq *package* pkg))) (defvar *make-package-use-defaults* '("COMMON-LISP" "CCL")) ;;; On principle, this should get exported here. Unfortunately, we ;;; can't execute calls to export quite yet. (defun make-package (name &key nicknames (use *make-package-use-defaults*) (internal-size 60) (external-size 10)) "Make a new package having the specified NAME, NICKNAMES, and USE list. :INTERNAL-SYMBOLS and :EXTERNAL-SYMBOLS are estimates for the number of internal and external symbols which will ultimately be present in the package. The default value of USE is implementation-dependent, and in this implementation it is NIL." (setq internal-size (require-type internal-size 'fixnum) external-size (require-type external-size 'fixnum)) (let* ((pkg-name (new-package-name name)) (pkg (gvector :package (%new-package-hashtable internal-size) (%new-package-hashtable external-size) nil nil (list pkg-name) nil (make-read-write-lock) nil))) (let* ((ref (register-package-ref pkg-name))) (setf (package-ref.pkg ref) pkg)) (use-package use pkg) (%add-nicknames nicknames pkg) (with-package-list-write-lock (push pkg %all-packages%)) pkg)) (defun new-package-name (name &optional package) (do* ((prompt "Enter package name to use instead of ~S .")) ((let* ((found (find-package (setq name (ensure-simple-string (string name)))))) (or (not found) (eq package found))) name) (restart-case (%error "Package name ~S is already in use." (list name) (%get-frame-ptr)) (new-name (new-name) :report (lambda (s) (format s prompt name)) :interactive (lambda () (list (block nil (catch-cancel (return (get-string-from-user (format nil prompt name)))) nil))) (if new-name (setq name new-name)))))) (defun new-package-nickname (name package) (setq name (string name)) (let* ((other (find-package name)) (prompt "Enter package name to use instead of ~S .")) (if other (unless (eq other package) (let* ((conflict-with-proper-name (string= (package-name other) name)) (condition (make-condition 'package-name-conflict-error :package package :format-arguments (list name other) :format-control (%str-cat "~S is already " (if conflict-with-proper-name "the " "a nick") "name of ~S.")))) (restart-case (%error condition nil (%get-frame-ptr)) (continue () :report (lambda (s) (format s "Don't make ~S a nickname for ~S" name package))) (new-name (new-name) :report (lambda (s) (format s prompt name)) :interactive (lambda () (list (block nil (catch-cancel (return (get-string-from-user (format nil prompt name)))) nil))) (if new-name (new-package-nickname new-name package))) (remove-conflicting-nickname () :report (lambda (s) (format s "Remove conflicting-nickname ~S from ~S." name other)) :test (lambda (&rest ignore) (declare (ignore ignore)) (not conflict-with-proper-name)) (rplacd (pkg.names other) (delete name (cdr (pkg.names other)) :test #'string=)) name)))) name))) (defun %add-nicknames (nicknames package) (let ((names (pkg.names package))) (dolist (name nicknames package) (let* ((ok-name (new-package-nickname name package))) (when ok-name (let* ((ref (register-package-ref ok-name))) (setf (package-ref.pkg ref) package) (push ok-name (cdr names)))))))) (defun find-symbol (string &optional package) "Return the symbol named STRING in PACKAGE. If such a symbol is found then the second value is :INTERNAL, :EXTERNAL or :INHERITED to indicate how the symbol is accessible. If no symbol is found then both values are NIL." (multiple-value-bind (sym flag) (%findsym (ensure-simple-string string) (pkg-arg (or package *package*))) (values sym flag))) (defun %pkg-ref-find-symbol (string ref) (multiple-value-bind (sym flag) (%findsym (ensure-simple-string string) (or (package-ref.pkg ref) (%kernel-restart $xnopkg (package-ref.name ref)))) (values sym flag))) ;;; Somewhat saner interface to %find-symbol (defun %findsym (string package) (%find-symbol string (length string) package)) (eval-when (:compile-toplevel) (declaim (inline %intern))) (defun %intern (str package) (setq str (ensure-simple-string str)) (with-package-lock (package) (multiple-value-bind (symbol where internal-offset external-offset) (%find-symbol str (length str) package) (if where (values symbol where) (values (%add-symbol str package internal-offset external-offset) nil))))) (defun intern (str &optional (package *package*)) "Return a symbol in PACKAGE having the specified NAME, creating it if necessary." (%intern str (pkg-arg package))) (defun %pkg-ref-intern (str ref) (%intern str (or (package-ref.pkg ref) (%kernel-restart $xnopkg (package-ref.name ref))))) (defun unintern (symbol &optional (package *package*)) "Makes SYMBOL no longer present in PACKAGE. If SYMBOL was present then T is returned, otherwise NIL. If PACKAGE is SYMBOL's home package, then it is made uninterned." (setq package (pkg-arg package)) (setq symbol (require-type symbol 'symbol)) (multiple-value-bind (foundsym table index) (%find-package-symbol (symbol-name symbol) package) (when (and table (eq symbol foundsym)) (when (memq symbol (pkg.shadowed package)) ;; A conflict is possible if more than one distinct ;; similarly-named external symbols exist in the packages used ;; by this one. Grovel around looking for such conflicts; if ;; any are found, signal an error (via %kernel-restart) which ;; offers to either shadowing-import one of the conflicting ;; symbols into the current package or abandon the attempt to ;; unintern in the first place. (let* ((first nil) (first-p nil) (name (symbol-name symbol)) (len (length name)) (others nil)) (declare (dynamic-extent first)) (with-package-lock (package) (dolist (pkg (pkg.used package)) (with-package-lock (pkg) (multiple-value-bind (found conflicting-sym) (%get-htab-symbol name len (pkg.etab pkg)) (when found (if first-p (unless (or (eq conflicting-sym first) (memq conflicting-sym others)) (push conflicting-sym others)) (setq first-p t first conflicting-sym))))))) (when others ;;If this returns, it will have somehow fixed things. (return-from unintern (%kernel-restart $xunintc symbol package (cons first others))))) ;; No conflicts found, but symbol was on shadowing-symbols list. Remove it atomically. (do* ((head (cons nil (pkg.shadowed package))) (prev head next) (next (cdr prev) (cdr next))) ((null next)) ; Should never happen (declare (dynamic-extent head) (list head prev next) (optimize (speed 3) (safety 0))) (when (eq (car next) symbol) (setf (cdr prev) (cdr next) (pkg.shadowed package) (cdr head)) (return)))) ;; Now remove the symbol from package; if package was its home ;; package, set its package to NIL. If we get here, the "table" ;; and "index" values returned above are still valid. (%svset (car table) index (package-deleted-marker)) (when (eq (symbol-package symbol) package) (%set-symbol-package symbol nil)) t))) (defun import-1 (package sym) (multiple-value-bind (conflicting-sym type internal-offset external-offset) (%findsym (symbol-name sym) package) (if (and type (neq conflicting-sym sym)) (let* ((external-p (eq type :inherited)) (condition (make-condition 'import-conflict-error :package package :imported-sym sym :conflicting-sym conflicting-sym :conflict-external external-p))) (restart-case (error condition) (continue () :report (lambda (s) (format s "Ignore attempt to import ~S to ~S." sym package))) (resolve-conflict () :report (lambda (s) (let* ((package-name (package-name package))) (if external-p (format s "~A ~s in package ~s ." 'shadowing-import sym package-name) (format s "~A ~s from package ~s ." 'unintern conflicting-sym package-name)))) (if external-p (shadowing-import-1 package sym) (progn (unintern conflicting-sym package) (import-1 package sym)))))) (unless (or (eq type :external) (eq type :internal)) (%insert-symbol sym package internal-offset external-offset))))) (defun import (sym-or-syms &optional package) "Make SYMBOLS accessible as internal symbols in PACKAGE. If a symbol is already accessible then it has no effect. If a name conflict would result from the importation, then a correctable error is signalled." (setq package (pkg-arg (or package *package*))) (if (listp sym-or-syms) (dolist (sym sym-or-syms) (import-1 package sym)) (import-1 package sym-or-syms)) t) (defun shadow-1 (package sym) (let* ((pname (ensure-simple-string (string sym))) (len (length pname))) (without-interrupts (multiple-value-bind (symbol where internal-idx external-idx) (%find-symbol pname len package) (if (or (eq where :internal) (eq where :external)) (pushnew symbol (pkg.shadowed package)) (push (%add-symbol pname package internal-idx external-idx) (pkg.shadowed package))))) nil)) (defun shadow (sym-or-symbols-or-string-or-strings &optional package) "Make an internal symbol in PACKAGE with the same name as each of the specified SYMBOLS. If a symbol with the given name is already present in PACKAGE, then the existing symbol is placed in the shadowing symbols list if it is not already present." (setq package (pkg-arg (or package *package*))) (if (listp sym-or-symbols-or-string-or-strings) (dolist (s sym-or-symbols-or-string-or-strings) (shadow-1 package s)) (shadow-1 package sym-or-symbols-or-string-or-strings)) t) (defun unexport (sym-or-symbols &optional package) "Makes SYMBOLS no longer exported from PACKAGE." (setq package (pkg-arg (or package *package*))) (if (listp sym-or-symbols) (dolist (sym sym-or-symbols) (unexport-1 package sym)) (unexport-1 package sym-or-symbols)) t) (defun unexport-1 (package sym) (when (eq package *keyword-package*) (error "Can't unexport ~S from ~S ." sym package)) (multiple-value-bind (foundsym foundp internal-offset external-offset) (%findsym (symbol-name sym) package) (unless foundp (error 'symbol-name-not-accessible :symbol-name (symbol-name sym) :package package)) (when (eq foundp :external) (let* ((evec (car (pkg.etab package))) (itab (pkg.itab package)) (ivec (car itab)) (icount&limit (cdr itab))) (declare (type cons itab icount&limit)) (setf (svref evec external-offset) (package-deleted-marker)) (setf (svref ivec internal-offset) (%symbol->symptr foundsym)) (if (eql (setf (car icount&limit) (the fixnum (1+ (the fixnum (car icount&limit))))) (the fixnum (cdr icount&limit))) (%resize-htab itab))))) nil) ;;; Both args must be packages. (defun %use-package-conflict-check (using-package package-to-use) (let ((already-used (pkg.used using-package))) (unless (or (eq using-package package-to-use) (memq package-to-use already-used)) ;; There are two types of conflict that can potentially occur: ;; 1) An external symbol in the package being used conflicts ;; with a symbol present in the using package ;; 2) An external symbol in the package being used conflicts ;; with an external symbol in some other package that's ;; already used. (let* ((ext-ext-conflicts nil) (used-using-conflicts nil) (shadowed-in-using (pkg.shadowed using-package)) (to-use-etab (pkg.etab package-to-use))) (without-interrupts (dolist (already already-used) (let ((user (if (memq package-to-use (pkg.used-by already)) package-to-use (if (memq package-to-use (pkg.used already)) already)))) (if user (let* ((used (if (eq user package-to-use) already package-to-use)) (user-etab (pkg.etab user)) (used-etab (pkg.etab used))) (dolist (shadow (pkg.shadowed user)) (let ((sname (symbol-name shadow))) (unless (member sname shadowed-in-using :test #'string=) (let ((len (length sname))) (when (%get-htab-symbol sname len user-etab) ; external in user (multiple-value-bind (external-in-used used-sym) (%get-htab-symbol sname len used-etab) (when (and external-in-used (neq used-sym shadow)) (push (list shadow used-sym) ext-ext-conflicts))))))))) ;; Remember what we're doing here ? ;; Neither of the two packages use the other. Iterate ;; over the external symbols in the package that has ;; the fewest external symbols and note conflicts with ;; external symbols in the other package. (let* ((smaller (if (%i< (%cadr to-use-etab) (%cadr (pkg.etab already))) package-to-use already)) (larger (if (eq smaller package-to-use) already package-to-use)) (larger-etab (pkg.etab larger)) (smaller-v (%car (pkg.etab smaller)))) (dotimes (i (uvsize smaller-v)) (declare (fixnum i)) (let ((symptr (%svref smaller-v i))) (when (symbolp symptr) (let* ((sym (%symptr->symbol symptr)) (symname (symbol-name sym))) (unless (member symname shadowed-in-using :test #'string=) (multiple-value-bind (found-in-larger sym-in-larger) (%get-htab-symbol symname (length symname) larger-etab) (when (and found-in-larger (neq sym-in-larger sym)) (push (list sym sym-in-larger) ext-ext-conflicts)))))))))))) ;; Now see if any non-shadowed, directly present symbols in ;; the using package conflicts with an external symbol in the ;; package being used. There are two ways of doing this; one ;; of them -may- be much faster than the other. (let* ((to-use-etab-size (%cadr to-use-etab)) (present-symbols-size (%i+ (%cadr (pkg.itab using-package)) (%cadr (pkg.etab using-package))))) (unless (eql 0 present-symbols-size) (if (%i< present-symbols-size to-use-etab-size) ;; Faster to look up each present symbol in to-use-etab. (let ((htabvs (list (%car (pkg.etab using-package)) (%car (pkg.itab using-package))))) (declare (dynamic-extent htabvs)) (dolist (v htabvs) (dotimes (i (the fixnum (uvsize v))) (declare (fixnum i)) (let ((symptr (%svref v i))) (when (symbolp symptr) (let* ((sym (%symptr->symbol symptr))) (unless (memq sym shadowed-in-using) (let* ((name (symbol-name symptr))) (multiple-value-bind (found-p to-use-sym) (%get-htab-symbol name (length name) to-use-etab) (when (and found-p (neq to-use-sym sym)) (push (list sym to-use-sym) used-using-conflicts))))))))))) ;; See if any external symbol present in the package ;; being used conflicts with any symbol present in the ;; using package. (let ((v (%car to-use-etab))) (dotimes (i (uvsize v)) (declare (fixnum i)) (let ((symptr (%svref v i))) (when (symbolp symptr) (let* ((sym (%symptr->symbol symptr))) (multiple-value-bind (using-sym found-p) (%find-package-symbol (symbol-name sym) using-package) (when (and found-p (neq sym using-sym) (not (memq using-sym shadowed-in-using))) (push (list using-sym sym) used-using-conflicts)))))))))))) (values ext-ext-conflicts used-using-conflicts))))) (defun use-package-1 (using-package package-to-use) (if (eq (setq package-to-use (pkg-arg package-to-use)) *keyword-package*) (error "~S can't use ~S." using-package package-to-use)) (do* ((used-external-conflicts nil) (used-using-conflicts nil)) ((and (null (multiple-value-setq (used-external-conflicts used-using-conflicts) (%use-package-conflict-check using-package package-to-use))) (null used-using-conflicts))) (if used-external-conflicts (%kernel-restart $xusecX package-to-use using-package used-external-conflicts) (if used-using-conflicts (%kernel-restart $xusec package-to-use using-package used-using-conflicts)))) (unless (memq using-package (pkg.used-by package-to-use)) ; Not already used in break loop/restart, etc. (push using-package (pkg.used-by package-to-use)) (push package-to-use (pkg.used using-package)))) (defun use-package (packages-to-use &optional package) "Add all the PACKAGES-TO-USE to the use list for PACKAGE so that the external symbols of the used packages are accessible as internal symbols in PACKAGE." (setq package (pkg-arg (or package *package*))) (if (listp packages-to-use) (dolist (to-use packages-to-use) (use-package-1 package to-use)) (use-package-1 package packages-to-use)) t) (defun shadowing-import-1 (package sym) (let* ((pname (symbol-name sym)) (len (length pname)) (need-add t)) (without-interrupts (multiple-value-bind (othersym htab offset) (%find-package-symbol pname package) (if htab (if (eq othersym sym) (setq need-add nil) (progn ; Delete conflicting symbol (if (eq (symbol-package othersym) package) (%set-symbol-package othersym nil)) (setf (%svref (car htab) offset) (package-deleted-marker)) (setf (pkg.shadowed package) (delete othersym (pkg.shadowed package) :test #'eq))))) (if need-add ; No symbols with same pname; intern & shadow (multiple-value-bind (xsym foundp internal-offset external-offset) (%find-symbol pname len package) (declare (ignore xsym foundp)) (%insert-symbol sym package internal-offset external-offset))) (pushnew sym (pkg.shadowed package)) nil)))) (defun shadowing-import (sym-or-syms &optional (package *package*)) "Import SYMBOLS into package, disregarding any name conflict. If a symbol of the same name is present, then it is uninterned." (setq package (pkg-arg package)) (if (listp sym-or-syms) (dolist (sym sym-or-syms) (shadowing-import-1 package sym)) (shadowing-import-1 package sym-or-syms)) t) (defun unuse-package (packages-to-unuse &optional package) "Remove PACKAGES-TO-UNUSE from the USE list for PACKAGE." (let ((p (pkg-arg (or package *package*)))) (flet ((unuse-one-package (unuse) (setq unuse (pkg-arg unuse)) (setf (pkg.used p) (nremove unuse (pkg.used p)) (pkg.used-by unuse) (nremove p (pkg.used-by unuse))))) (declare (dynamic-extent #'unuse-one-package)) (if (listp packages-to-unuse) (dolist (u packages-to-unuse) (unuse-one-package u)) (unuse-one-package packages-to-unuse)) t))) (defun delete-package (package) "Delete the package designated by PACKAGE-DESIGNATOR from the package system data structures." (unless (packagep package) (setq package (or (find-package package) (progn (cerror "Do nothing" 'no-such-package :package package) (return-from delete-package nil))))) (with-package-list-read-lock (unless (memq package %all-packages%) (return-from delete-package nil))) (when (pkg.used-by package) (cerror "unuse ~S" 'package-is-used-by :package package :using-packages (pkg.used-by package))) (while (pkg.used-by package) (unuse-package package (car (pkg.used-by package)))) (while (pkg.used package) (unuse-package (car (pkg.used package)) package)) (setf (pkg.shadowed package) nil) (with-package-list-write-lock (setq %all-packages% (nremove package %all-packages%))) (dolist (n (pkg.names package)) (let* ((ref (register-package-ref n))) (setf (package-ref.pkg ref) nil))) (setf (pkg.names package) nil) (let* ((ivec (car (pkg.itab package))) (evec (car (pkg.etab package))) (deleted (package-deleted-marker))) (dotimes (i (the fixnum (length ivec))) (let* ((sym (%svref ivec i))) (setf (%svref ivec i) deleted) ; in case it's in STATIC space (when (symbolp sym) (if (eq (symbol-package sym) package) (%set-symbol-package sym nil))))) (dotimes (i (the fixnum (length evec))) (let* ((sym (%svref evec i))) (setf (%svref evec i) deleted) ; in case it's in STATIC space (when (symbolp sym) (if (eq (symbol-package sym) package) (%set-symbol-package sym nil)))))) (let ((itab (pkg.itab package)) (etab (pkg.etab package)) (v '#(nil nil nil))) (%rplaca itab v) (%rplaca etab v) (%rplaca (%cdr itab) 0) (%rplaca (%cdr etab) 0) (%rplacd (%cdr itab) #x4000) (%rplacd (%cdr etab) #x4000)) t) (defun %find-package-symbol (string package &optional (len (length string))) (let* ((etab (pkg.etab package)) (itab (pkg.itab package))) (multiple-value-bind (foundp sym offset) (%get-htab-symbol string len itab) (if foundp (values sym itab offset) (progn (multiple-value-setq (foundp sym offset) (%get-htab-symbol string len etab)) (if foundp (values sym etab offset) (values nil nil nil))))))) ;;;For the inspector, number of symbols in pkg. (defun %pkgtab-count (pkgtab) (let* ((n 0)) (declare (fixnum n)) (dovector (x (pkgtab-table pkgtab) n) (when (symbolp x) (incf n))))) (defun %resize-package (pkg) (%resize-htab (pkg.itab pkg)) (%resize-htab (pkg.etab pkg)) pkg) ;These allow deleted packages, so can't use pkg-arg which doesn't. ;Of course, the wonderful world of optional arguments comes in handy. (defun pkg-arg-allow-deleted (pkg) (pkg-arg pkg t)) (defun package-name (pkg) (%car (pkg.names (pkg-arg-allow-deleted pkg)))) ;;>> Shouldn't these copy-list their result so that the user ;;>> can't cause a crash through evil rplacding? ;Of course that would make rplacding less evil, and then how would they ever learn? (defun package-nicknames (pkg) (%cdr (pkg.names (pkg-arg-allow-deleted pkg)))) (defun package-use-list (pkg) (pkg.used (pkg-arg-allow-deleted pkg))) (defun package-used-by-list (pkg) (pkg.used-by (pkg-arg-allow-deleted pkg))) (defun package-shadowing-symbols (pkg) (pkg.shadowed (pkg-arg-allow-deleted pkg))) ;;; This assumes that all symbol-names and package-names are strings. (defun %define-package (name size external-size ; extension (may be nil.) nicknames shadow shadowing-import-from-specs use import-from-specs intern export &optional doc) (if (eq use :default) (setq use *make-package-use-defaults*)) (let* ((pkg (find-package name))) (if pkg ;; Restarts could offer several ways of fixing this. (unless (string= (package-name pkg) name) (cerror "Redefine ~*~S" "~S is already a nickname for ~S" name pkg)) (setq pkg (make-package name :use nil :internal-size (or size 60) :external-size (or external-size (max (length export) 1))))) (unuse-package (package-use-list pkg) pkg) (rename-package pkg name nicknames) (flet ((operation-on-all-specs (function speclist) (let ((to-do nil)) (dolist (spec speclist) (let ((from (pop spec))) (dolist (str spec) (multiple-value-bind (sym win) (find-symbol str from) (if win (push sym to-do) ; This should (maybe) be a PACKAGE-ERROR. (cerror "Ignore attempt to ~s ~s from package ~s" "Cannot ~s ~s from package ~s" function str from)))))) (when to-do (funcall function to-do pkg))))) (dolist (sym shadow) (shadow sym pkg)) (operation-on-all-specs 'shadowing-import shadowing-import-from-specs) (use-package use pkg) (operation-on-all-specs 'import import-from-specs) (dolist (str intern) (intern str pkg)) (when export (let* ((syms nil)) (dolist (str export) (multiple-value-bind (sym found) (find-symbol str pkg) (unless found (setq sym (intern str pkg))) (push sym syms))) (export syms pkg))) (when (and doc *save-doc-strings*) (set-documentation pkg t doc)) pkg))) (defun %setup-pkg-iter-state (pkg-list types) (collect ((steps)) (flet ((cons-pkg-iter-step (package type table &optional shadowed) (steps (vector package type table shadowed nil nil)))) (let* ((pkgs (if (listp pkg-list) (mapcar #'pkg-arg pkg-list) (list (pkg-arg pkg-list))))) (dolist (pkg pkgs) (dolist (type types) (case type (:internal (cons-pkg-iter-step pkg type (pkg.itab pkg))) (:external (cons-pkg-iter-step pkg type (pkg.etab pkg))) (:inherited (let* ((shadowed (pkg.shadowed pkg)) (used (pkg.used pkg))) (dolist (u used) (cons-pkg-iter-step pkg type (pkg.etab u) shadowed))))))))) (vector nil (steps)))) (defun %pkg-iter-next (state) (flet ((get-step () (let* ((step (pkg-iter.step state))) (loop (if (and step (> (pkg-iter-step.index step) 0)) (return step)) (when (setq step (pop (pkg-iter.remaining-steps state))) (setf (pkg-iter.step state) step) (setf (pkg-iter-step.index step) (length (setf (pkg-iter-step.vector step) (pkgtab-table (pkg-iter-step.table step)))))) (unless step (return)))))) (loop (let* ((step (get-step))) (when (null step) (return)) (multiple-value-bind (symbol found) (%htab-symbol (pkg-iter-step.vector step) (decf (pkg-iter-step.index step))) (when (and found (not (member symbol (pkg-iter-step.shadowed step) :test #'string=))) (return (values t symbol (pkg-iter-step.type step) (pkg-iter-step.pkg step))))))))) ;;; For do-symbols and with-package-iterator ;;; string must be a simple string ;;; package must be a package ;;; Wouldn't it be nice if this distinguished "not found" from "found NIL" ? (defun %name-present-in-package-p (string package) (values (%find-package-symbol string package))) ;;; This is supposed to be (somewhat) like the lisp machine's MAKE-PACKAGE. ;;; Accept and ignore some keyword arguments, accept and process some others. (defun lispm-make-package (name &key (use *make-package-use-defaults*) nicknames ;prefix-name ;invisible (shadow nil shadow-p) (export nil export-p) (shadowing-import nil shadowing-import-p) (import nil import-p) (import-from nil import-from-p) ;relative-names ;relative-names-for-me ;size ;hash-inherited-symbols ;external-only ;include ;new-symbol-function ;colon-mode ;prefix-intern-function &allow-other-keys) ; (declare (ignore prefix-name invisible relative-names relative-names-for-me ; size hash-inherited-symbols external-only include ; new-symbol-function colon-mode prefix-intern-function)) (let ((pkg (make-package name :use NIL :nicknames nicknames))) (when shadow-p (shadow shadow pkg)) (when shadowing-import-p (shadowing-import shadowing-import pkg)) (use-package use pkg) (when import-from-p (let ((from-pkg (pop import-from))) (dolist (name import-from) (multiple-value-bind (sym win) (find-symbol (string name) from-pkg) (when win (import-1 pkg sym)))))) (when import-p (import import pkg)) (when export-p (let* ((syms nil)) (dolist (name export) (multiple-value-bind (sym win) (find-symbol (string name) pkg) (unless win (setq sym (intern (string name) pkg))) (push sym syms))) (export syms pkg))) pkg))