From b60a65ba9a2e42dea17284b9101f81066e85e1d6 Mon Sep 17 00:00:00 2001 From: Tobias C Rittweiler Date: Thu, 25 Dec 2008 15:21:21 +0100 Subject: [PATCH] Implement FIND-PACKAGE-FROM-SUBSTRING which works in the same spirit as FIND-SYMBOL*. A later changeset will make use of this in the reader, so we do not cons up a new string for each explicitly given package qualifier. --- build-order.lisp-expr | 9 ++-- src/code/target-package.lisp | 114 ++++++++++++++++++++++++++++++++----------- 2 files changed, 91 insertions(+), 32 deletions(-) diff --git a/build-order.lisp-expr b/build-order.lisp-expr index c44ad4382..7dd338891 100644 --- a/build-order.lisp-expr +++ b/build-order.lisp-expr @@ -658,14 +658,15 @@ ("src/code/eval" :not-host) ; uses INFO, wants compiler macro ("src/code/target-sap" :not-host) ; uses SAP-INT type - ("src/code/target-package" :not-host) ; needs "code/package" - ("src/code/target-random" :not-host) ; needs "code/random" ("src/code/target-hash-table" :not-host) ; needs "code/hash-table" + ("src/code/target-package" :not-host) ; needs "code/package", and DEF-H-T-TEST + ; from "code/target-hash-table" + ("src/code/target-random" :not-host) ; needs "code/random" ("src/code/reader" :not-host) ; needs "code/readtable" ("src/code/target-stream" :not-host) ; needs WHITESPACEP from "code/reader" ("src/code/target-pathname" :not-host) ; needs "code/pathname" - ("src/code/unix-pathname" :not-host) - ("src/code/win32-pathname" :not-host) + ("src/code/unix-pathname" :not-host) + ("src/code/win32-pathname" :not-host) ("src/code/filesys" :not-host) ; needs HOST from "code/pathname" ("src/code/save" :not-host) ; uses the definition of PATHNAME diff --git a/src/code/target-package.lisp b/src/code/target-package.lisp index 9c1052517..f78d5bfe6 100644 --- a/src/code/target-package.lisp +++ b/src/code/target-package.lisp @@ -317,17 +317,57 @@ error if any of PACKAGES is not a valid package designator." (defun package-external-symbol-count (package) (%package-hashtable-symbol-count (package-external-symbols package))) + +;;; FIXME: should be declared of type PACKAGE, with no NIL init form, +;;; after I get around to cleaning up DOCUMENTATION. (defvar *package* (error "*PACKAGE* should be initialized in cold load!") #!+sb-doc "the current package") -;;; FIXME: should be declared of type PACKAGE, with no NIL init form, -;;; after I get around to cleaning up DOCUMENTATION -;;; a map from package names to packages +;;; A map from package names to packages. +;; +;; This will be set to a hash-table with a customized test and hashing +;; function. The customized functions allow (CONS STRING LENGTH) as a +;; key to mean (SUBSEQ STRING 0 LENGTH), but without the consing. We +;; need this to implement FIND-PACKAGE-FROM-SUBSTRING which is used by +;; the reader, so we don't have to cons up a new string for each +;; explicitly given package qualifier. +;; (defvar *package-names*) + +(defun resolve-package-name-designator (designator) + ;; FIXME: Perhaps we can declare the returned string to be a + ;; SIMPLE-STRING. This would help the %SXHASH-SUBSTRING below. + (declare (type (or string cons) designator)) + (if (consp designator) + (destructuring-bind (str . length) designator + (declare (string str) (index length)) + (values str length)) + designator)) + +(defun package-name-= (designator1 designator2) + (multiple-value-bind (str1 length1) + (resolve-package-name-designator designator1) + (multiple-value-bind (str2 length2) + (resolve-package-name-designator designator2) + (string= str1 str2 :end1 length1 :end2 length2)))) + +(defun package-name-sxhash (designator) + (multiple-value-bind (str length) + (resolve-package-name-designator designator) + (if length + (%sxhash-substring str length) + (sxhash str)))) + (declaim (type hash-table *package-names*)) (!cold-init-forms - (setf *package-names* (make-hash-table :test 'equal))) + (/show0 "About to define PACKAGE-NAME-= as hash table test") + (sb!int:define-hash-table-test 'package-name-= + #'package-name-= #'package-name-sxhash) + + (/show0 "About to set *PACKAGE-NAMES*") + (setf *package-names* (make-hash-table :test 'package-name-=))) + ;;; This magical variable is T during initialization so that ;;; USE-PACKAGE's of packages that don't yet exist quietly win. Such @@ -347,35 +387,52 @@ error if any of PACKAGES is not a valid package designator." (define-condition bootstrap-package-not-found (condition) ((name :initarg :name :reader bootstrap-package-name))) + +(defun bootstrap-package-name-p (package-name) + (let ((mismatch (mismatch "SB!" package-name))) + (and mismatch (= mismatch 3)))) + +(defun run-debootstrap-hook (package-name) + (restart-case + (signal 'bootstrap-package-not-found :name package-name) + (debootstrap-package () + (if (string= package-name "SB!XC") + (find-package "COMMON-LISP") + (find-package + (substitute #\- #\! package-name :count 1)))))) + (defun debootstrap-package (&optional condition) (invoke-restart (find-restart-or-control-error 'debootstrap-package condition))) +(defun find-package-from-substring (string &optional length) + (declare (type string string)) + (let ((packageoid (gethash (if length + (cons string length) ; cf. PACKAGE-NAME-= + string) + *package-names*))) + (if (and (null packageoid) + (bootstrap-package-name-p string) + ;; KLUDGE: When *IN-PACKAGE-INIT* is T, we're about to + ;; create all packages during cold-init, including the + ;; SB!FOO packages. We come here because MAKE-PACKAGE + ;; invokes FIND-PACKAGE. In this case, PACKAGEOID is NIL + ;; (SB!FOO doesn't exist yet), but we do not want to run + ;; the debootstrap hook because the condition system + ;; isn't fully ready yet. + (not *in-package-init*)) + (run-debootstrap-hook string) + packageoid))) + (defun find-package (package-designator) - (flet ((find-package-from-string (string) - (declare (type string string)) - (let ((packageoid (gethash string *package-names*))) - (when (and (null packageoid) - (not *in-package-init*) ; KLUDGE - (let ((mismatch (mismatch "SB!" string))) - (and mismatch (= mismatch 3)))) - (restart-case - (signal 'bootstrap-package-not-found :name string) - (debootstrap-package () - (return-from find-package - (if (string= string "SB!XC") - (find-package "COMMON-LISP") - (find-package - (substitute #\- #\! string :count 1))))))) - packageoid))) - (typecase package-designator - (package package-designator) - (symbol (find-package-from-string (symbol-name package-designator))) - (string (find-package-from-string package-designator)) - (character (find-package-from-string (string package-designator))) - (t (error 'type-error - :datum package-designator - :expected-type '(or character package string symbol)))))) + (typecase package-designator + (package package-designator) + (symbol (find-package-from-substring (symbol-name package-designator))) + (string (find-package-from-substring package-designator)) + (character (find-package-from-substring (string package-designator))) + (t (error 'type-error + :datum package-designator + :expected-type '(or character package string symbol))))) ;;; Return a list of packages given a package designator or list of ;;; package designators, or die trying. @@ -1323,6 +1380,7 @@ PACKAGE." ;; Put shadowing symbols in the shadowing symbols list. (setf (package-%shadowing-symbols pkg) (sixth spec)) + ;; Set the package documentation (setf (package-doc-string pkg) (seventh spec)))) -- 2.11.4.GIT