From 930cc263ba4367f9c891682d8e7c47393ab9542f Mon Sep 17 00:00:00 2001
From: dtc <dtc>
Date: Thu, 30 Nov 2000 05:33:17 +0000
Subject: [PATCH] Support for relative package names, conditional upon the
 :relative-package-names feature, and based on the public domain example code
 from Franz Inc.

---
 code/exports.lisp |   5 +-
 code/package.lisp | 223 +++++++++++++++++++++++++++++++++++++---------
 2 files changed, 185 insertions(+), 43 deletions(-)

diff --git a/code/exports.lisp b/code/exports.lisp
index 0878ce56a..1ed6eb5cf 100644
--- a/code/exports.lisp
+++ b/code/exports.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.174 2000/08/24 16:39:30 pw Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/exports.lisp,v 1.175 2000/11/30 05:33:16 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -952,7 +952,8 @@
 	     "MAKE-STREAM-COMMAND" "MAKE-WEAK-POINTER"
              "MAYBE-INLINE" "MEMQ" "NAME-KEYSYM" "NTOHL" "NTOHS"
              "OBJECT-SET-EVENT-HANDLER" "OLD-TRACE" "OLD-UNTRACE" "ONCE-ONLY"
-             "OPEN-CLX-DISPLAY" "OPTIMIZE-INTERFACE" "PARSE-TIME"
+             "OPEN-CLX-DISPLAY" "OPTIMIZE-INTERFACE"
+	     "PACKAGE-CHILDREN" "PACKAGE-PARENT" "PARSE-TIME"
              "PRINT-DIRECTORY" "PRINT-HERALD" "PRINT-PRETTY-KEY"
              "PRINT-PRETTY-KEY-EVENT" "PROCESS-ALIVE-P" "PROCESS-CLOSE"
              "PROCESS-CORE-DUMPED" "PROCESS-ERROR" "PROCESS-EXIT-CODE"
diff --git a/code/package.lisp b/code/package.lisp
index 3818d3df4..31282a8a9 100644
--- a/code/package.lisp
+++ b/code/package.lisp
@@ -5,7 +5,7 @@
 ;;; Carnegie Mellon University, and has been placed in the public domain.
 ;;;
 (ext:file-comment
-  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/package.lisp,v 1.56 2000/07/06 06:39:20 dtc Exp $")
+  "$Header: /Volumes/share2/src/cmucl/cvs2git/cvsroot/src/code/package.lisp,v 1.57 2000/11/30 05:33:17 dtc Exp $")
 ;;;
 ;;; **********************************************************************
 ;;;
@@ -27,7 +27,7 @@
 
 (in-package "EXTENSIONS")
 (export '(*keyword-package* *lisp-package* *default-package-use-list*
-			    map-apropos))
+	  map-apropos package-children package-parent))
 
 (in-package "KERNEL")
 (export '(%in-package old-in-package %defpackage))
@@ -124,33 +124,178 @@
 (defvar *in-package-init* nil)
 (defvar *deferred-use-packages* nil)
 
-;;; Find-Package  --  Public
+(defun stringify-name (name kind)
+  (typecase name
+    (simple-string name)
+    (string (coerce name 'simple-string))
+    (symbol (symbol-name name))
+    (base-char
+     (let ((res (make-string 1)))
+       (setf (schar res 0) name)
+       res))
+    (t
+     (error "Bogus ~A name: ~S" kind name))))
+
+(defun stringify-names (names kind)
+  (mapcar #'(lambda (name)
+	      (stringify-name name kind))
+	  names))
+
+;;; package-namify  --  Internal
 ;;;
+;;;    Make a package name into a simple-string.
 ;;;
-(defun find-package (name)
-  "Find the package having the specified name."
-  (if (packagep name)
-      name
-      (values (gethash (string name) *package-names*))))
+(defun package-namify (n)
+  (stringify-name n "package"))
 
-;;; Package-Listify  --  Internal
+;;; package-namestring  --  Internal
 ;;;
-;;;    Return a list of packages given a package-or-string-or-symbol or
-;;; list thereof, or die trying.
+;;;    Take a package-or-string-or-symbol and return a package name.
 ;;;
-(defun package-listify (thing)
-  (let ((res ()))
-    (dolist (thing (if (listp thing) thing (list thing)) res)
-      (push (package-or-lose thing) res))))
+(defun package-namestring (thing)
+  (if (packagep thing)
+      (let ((name (package-%name thing)))
+	(or name
+	    (error "Can't do anything to a deleted package: ~S" thing)))
+      (package-namify thing)))
 
-;;; PACKAGE-NAMIFY  --  Internal
+;;; package-name-to-package  --  Internal
 ;;;
-;;;    Make a package name into a simple-string.
+;;; Given a package name, a simple-string, do a package name lookup.
 ;;;
-(defun package-namify (n)
-  (stringify-name n "package"))
+(defun package-name-to-package (name)
+  (declare (simple-string name))
+  (values (gethash name *package-names*)))
+
+;;; package-parent  --  Internal.
+;;;
+;;; Because this function is called via the reader, we want it to be as
+;;; fast as possible.
+;;;
+#+relative-package-names
+(defun package-parent (package-specifier)
+  "Given package-specifier, a package, symbol or string, return the
+  parent package.  If there is not a parent, signal an error."
+  (declare (optimize (speed 3)))
+  (flet ((find-last-dot (name)
+           (do* ((len (1- (length name)))
+		 (i len (1- i)))
+		((= i -1) nil)
+             (declare (fixnum len i))
+             (when (char= #\. (schar name i)) (return i)))))
+    (let* ((child (package-namestring package-specifier))
+           (dot-position (find-last-dot child)))
+      (cond (dot-position
+             (let ((parent (subseq child 0 dot-position)))
+               (or (package-name-to-package parent)
+		   (error "The parent of ~a does not exist." child))))
+            (t
+	     (error "There is no parent of ~a." child))))))
+
+
+;;; package-children  --  Internal.
+;;;
+;;; While this function is not called via the reader, we do want it to be
+;;; fast.
+;;;
+#+relative-package-names
+(defun package-children (package-specifier &key (recurse t))
+  "Given package-specifier, a package, symbol or string, return all the
+  packages which are in the hierarchy 'under' the given package.  If
+  :recurse is nil, then only return the immediate children of the package."
+  (declare (optimize (speed 3)))
+  (let ((res ())
+        (parent (package-namestring package-specifier)))
+    (labels
+        ((string-prefix-p (prefix string)
+	   (declare (simple-string prefix string))
+           ;; Return length of `prefix' if `string' starts with `prefix'.
+           ;; We don't use `search' because it does much more than we need
+           ;; and this version is about 10x faster than calling `search'.
+           (let ((prefix-len (length prefix))
+                 (seq-len (length string)))
+             (declare (type index prefix-len seq-len))
+             (when (>= prefix-len seq-len)
+               (return-from string-prefix-p nil))
+             (do ((i 0 (1+ i)))
+                 ((= i prefix-len) prefix-len)
+               (declare (type index i))
+               (unless (char= (schar prefix i) (schar string i))
+                 (return nil)))))
+         (test-package (package-name package)
+	   (declare (simple-string package-name)
+		    (type package package))
+           (let ((prefix
+                  (string-prefix-p (concatenate 'simple-string parent ".")
+                                   package-name)))
+             (cond (recurse
+		    (when prefix
+		      (pushnew package res)))
+                   (t
+		    (when (and prefix
+			       (not (find #\. package-name :start prefix)))
+		      (pushnew package res)))))))
+      (maphash #'test-package *package-names*)
+      res)))
+
+;;; relative-package-name-to-package  --  Internal
+;;;
+;;; Given a package name, a simple-string, do a relative package name lookup.
+;;; It is intended that this function will be called from find-package.
+;;;
+#+relative-package-names
+(defun relative-package-name-to-package (name)
+  (declare (simple-string name)
+	   (optimize (speed 3)))
+  (flet ((relative-to (package name)
+	   (declare (type package package)
+		    (simple-string name))
+           (if (string= "" name)
+	       package
+	       (let ((parent-name (package-%name package)))
+		 (unless parent-name
+		   (error "Can't do anything to a deleted package: ~S"
+			  package))
+		 (package-name-to-package
+		  (concatenate 'simple-string parent-name "." name)))))
+         (find-non-dot (name)
+           (do* ((len (length name))
+                 (i 0 (1+ i)))
+		((= i len) nil)
+             (declare (type index len i))
+             (when (char/= #\. (schar name i)) (return i)))))
+    (when (char= #\. (schar name 0))
+      (let* ((last-dot-position (or (find-non-dot name) (length name)))
+             (n-dots last-dot-position)
+             (name (subseq name last-dot-position)))
+        (cond ((= 1 n-dots)
+               ;; relative to current package
+               (relative-to *package* name))
+              (t
+               ;; relative to our (- n-dots 1)'th parent
+               (let ((package *package*)
+                     (tmp nil))
+                 (dotimes (i (1- n-dots))
+		   (declare (fixnum i))
+		   (setq tmp (package-parent package))
+                   (unless tmp
+		     (error "The parent of ~a does not exist." package))
+                   (setq package tmp))
+                 (relative-to package name))))))))
+
+;;; find-package  --  Public
+;;;
+;;;
+(defun find-package (name)
+  "Find the package having the specified name."
+  (if (packagep name)
+      name
+      (let ((name (package-namify name)))
+	(or (package-name-to-package name)
+	    #+relative-package-names
+	    (relative-package-name-to-package name)))))
 
-;;; Package-Or-Lose  --  Internal
+;;; package-or-lose  --  Internal
 ;;;
 ;;;    Take a package-or-string-or-symbol and return a package.
 ;;;
@@ -161,9 +306,9 @@
 	 thing)
 	(t
 	 (let ((thing (package-namify thing)))
-	   (cond ((gethash thing *package-names*))
+	   (cond ((package-name-to-package thing))
 		 (t
-		  ;; ANSI spec's TYPE-ERROR where this is called. But,
+		  ;; ANSI spec's type-error where this is called. But,
 		  ;; but the resulting message is somewhat unclear.
 		  ;; May need a new condition type?
 		  (with-simple-restart
@@ -173,6 +318,16 @@
 			   :expected-type 'package))
 		  (make-package thing)))))))
 
+;;; package-listify  --  Internal
+;;;
+;;;    Return a list of packages given a package-or-string-or-symbol or
+;;; list thereof, or die trying.
+;;;
+(defun package-listify (thing)
+  (let ((res ()))
+    (dolist (thing (if (listp thing) thing (list thing)) res)
+      (push (package-or-lose thing) res))))
+
 
 ;;;; Package-Hashtables
 ;;;
@@ -748,20 +903,6 @@
 					but have common elements ~%   ~S"
 		       :format-arguments (list (car x)(car y) z)))))
 
-(defun stringify-name (name kind)
-  (typecase name
-    (simple-string name)
-    (string (coerce name 'simple-string))
-    (symbol (symbol-name name))
-    (base-char (string name))
-    (t
-     (error "Bogus ~A name: ~S" kind name))))
-
-(defun stringify-names (names kind)
-  (mapcar #'(lambda (name)
-	      (stringify-name name kind))
-	  names))
-
 (defun %defpackage (name nicknames size shadows shadowing-imports
 			 use imports interns exports doc-string)
   (declare (type simple-base-string name)
@@ -856,7 +997,7 @@
   (check-type nicknames list)
   (dolist (n nicknames)
     (let* ((n (package-namify n))
-	   (found (gethash n *package-names*)))
+	   (found (package-name-to-package n)))
       (cond ((not found)
 	     (setf (gethash n *package-names*) package)
 	     (push n (package-%nicknames package)))
@@ -1064,7 +1205,7 @@
 		 (add-symbol (package-internal-symbols package) symbol)))
 	  (values symbol nil)))))
 
-;;; Find-Symbol*  --  Internal
+;;; find-symbol*  --  Internal
 ;;;
 ;;;    Check internal and external symbols, then scan down the list
 ;;; of hashtables for inherited symbols.  When an inherited symbol
@@ -1094,9 +1235,9 @@
 	      (shiftf (cdr prev) (cdr table) (cdr head) table))
 	    (return-from find-symbol* (values symbol :inherited))))))))
 
-;;; Find-External-Symbol  --  Internal
+;;; find-external-symbol  --  Internal
 ;;;
-;;;    Similar to Find-Symbol, but only looks for an external symbol.
+;;;    Similar to find-symbol, but only looks for an external symbol.
 ;;; This is used for fast name-conflict checking in this file and symbol
 ;;; printing in the printer.
 ;;;
@@ -1110,7 +1251,7 @@
 			string length hash ehash)
       (values symbol found))))
 
-;;; Unintern  --  Public
+;;; unintern  --  Public
 ;;;
 ;;;    If we are uninterning a shadowing symbol, then a name conflict can
 ;;; result, otherwise just nuke the symbol.
-- 
GitLab