;;; -*- Mode:Lisp; Readtable:T; Package:USER; Base:8; Patch-File:T -*-
;;; Private patches made by rg
;;; Reason:
;;;  Add Zwei command Set Package Root.
;;; Reason:
;;;  allows the user to change the root associated with buffer or file
;;; Written 23-Jul-87 23:28:34 by rg at site LMI Cambridge
;;; while running on Harpo from band 4
;;; with Experimental System 122.9, Experimental Local-File 73.0, Experimental FILE-Server 22.0, Experimental Unix-Interface 11.0, Experimental Tape 17.1, Experimental Tiger 26.0, Experimental KERMIT 33.1, Experimental ZMail 71.0, Experimental Lambda-Diag 15.0, microcode 1754, SDU Boot Tape 3.12, SDU ROM 103, GC.



; From file DJ: L.ZWEI; ZMNEW.LISP#51 at 28-Jul-87 00:56:56
#8R ZWEI#: 
(COMPILER-LET ((*PACKAGE* (PKG-FIND-PACKAGE "ZWEI")))
  (COMPILER::PATCH-SOURCE-FILE "SYS: ZWEI; ZMNEW  "

(defcom com-set-package-root "Change the package root associated with buffer or file.
If a package with the same name as the current package exists in that hierarchy,
select it, otherwise, offer to create it.  Then you will be asked whether to
resectionize the buffer.  If you say yes, all function definitions in the buffer
will be recorded under symbols in the new package." ()
  (let (root-alist)
    (dolist (pkg *all-packages*)
      (let ((root (get pkg ':root)))
	(unless (or (null root)
		    (cl:member root root-alist :key 'cdr))
	  (push (cons (package-name root) root) root-alist)
	  (dolist (nick (package-nicknames root))
	    (push (cons nick root) root-alist)))))
    (push '("" . nil) root-alist)
    (push `("GLOBAL" . ,(find-package 'global)) root-alist) 
    (let ((new-root (car (completing-read-from-mini-buffer
			   "Set new root package: " root-alist ))))
      (let ((pkg (find-package (si:package-primary-name *package*) (find-package new-root)))
	    (pkg-name (package-name *package*))
	    (pkg-nicknames (package-nicknames *package*)))
	(if pkg
	    (pkg-goto pkg () new-root)
	  (IF (YES-OR-NO-P (FORMAT NIL "Package ~A does not exist.  Create? " PKG))
	      (progn
		(if new-root
		    (pkg-goto new-root)
		  (pkg-goto 'user)
		(pkg-goto (make-package pkg-name :nicknames pkg-nicknames)))
	    (BARF)))))))
  (SETF (BUFFER-PACKAGE *INTERVAL*) *PACKAGE*)
  (WHEN (FQUERY NIL "Resectionize the buffer? ")
    (SEND *INTERVAL* ':REMPROP ':DONT-SECTIONIZE)
    (SECTIONIZE-BUFFER *INTERVAL*))
  DIS-NONE)

))