(FILECREATED "16-Sep-86 18:44:45" {PHYLUM}<LANNING>LISP>USERS>LOADMENUITEMS.;2
 5816   

      changes to:  (FNS LOADMENUITEMSCOMS)
		   (FILEPKGCOMS LOADMENUITEMS)
		   (VARS LOADMENUITEMSCOMS)

      previous date: "16-Sep-86 18:16:44" {PHYLUM}<LANNING>LISP>USERS>LOADMENUITEMS.;1)


(* Copyright (c) 1986 by Xerox Corporation. All rights reserved.)

(PRETTYCOMPRINT LOADMENUITEMSCOMS)

(RPAQQ LOADMENUITEMSCOMS
 ((* * Defines a new FILEPKGCOM called LOADMENUITEMS that can be used to 
			       add entries onto the background menu for easy loading of utility files)
			    (FNS AddLoadMenuItem LoadUtilityPackage LOADMENUITEMSCOMS)
			    (FILEPKGCOMS LOADMENUITEMS)))
(* * Defines a new FILEPKGCOM called LOADMENUITEMS that can be used to add entries onto the 
background menu for easy loading of utility files)


(DEFINEQ

(AddLoadMenuItem

  [LAMBDA (group fileDescr startUpForm)                      (* smL "15-Sep-86 10:22")


          (* * Add a menu item to the background menu that will load the file{s} -

	  group is the submenu name for this file, default is Misc -

	  fileDescr is a list that can be passed to DOFILESLOAD to load the file{s} -

	  startUpForm is an optional form that will be evaluated after the LOAD, default will print a nice msg in the prompt 

	  window)



    (DECLARE
 (
GLOBALVARS
 BackgroundMenu BackgroundMenuCommands))
    (LET* [(group (
OR
 group (
QUOTE
 Misc)))
	   (fileDescr (
MKLIST
 fileDescr))
	   [fileName (for
 x in
 fileDescr thereis
 (
NOT
 (
LISTP
 x]
	   [startUpForm (
OR
 startUpForm (
BQUOTE
 (
PROMPTPRINT
 (
QUOTE
 (\, fileName))
								   " loaded"]
	   [loadForm (
BQUOTE
 (
QUOTE
 (
LISPXEVAL
 [
QUOTE
 (LoadUtilityPackage

								(
QUOTE
 (\, fileDescr))
								(
QUOTE
 (\, startUpForm]
						     "<mouse event>←"]
	   (topLevelItem (
OR
 (for
 item in
 BackgroundMenuCommands thereis
 (
STREQUAL

										   (
CAR
 item)
										   "Load utility"))
			       (LET [(topLevelItem (
LIST
 "Load utility" NIL "Load a utility file"
							   (
LIST
 (
QUOTE
 SUBITEMS]
				    (/push
 BackgroundMenuCommands topLevelItem)
				topLevelItem)))
	   (groupItem (
OR
 (
ASSOC
 group (
CDAR
 (
LAST
 topLevelItem)))
			    (LET [(groupList (
LIST
 group NIL "Load a utility file"
						     (
LIST
 (
QUOTE
 SUBITEMS]
			         (/push
 (
CDAR
 (
LAST
 topLevelItem))
					  groupList)
			         [
SORT
 (
CDAR
 (
LAST
 topLevelItem))
					 (
FUNCTION
 (LAMBDA (x y)
					     (
ALPHORDER
 (
CAR
 x)
							  (
CAR
 y]
			     groupList]
          (
/NCONC1
 (
CAR
 (
LAST
 groupItem))
		     (
LIST
 fileName loadForm (
CONCAT
 "Load " fileName)))
          [
SORT
 (
CDAR
 (
LAST
 groupItem))
		  (
FUNCTION
 (LAMBDA (x y)
		      (
ALPHORDER
 (
CAR
 x)
				   (
CAR
 y]
          (
SETQ
 BackgroundMenu NIL)
          (
UNDOSAVE
 (
BQUOTE
 (
SETQ
 , BackgroundMenu NIL])

(LoadUtilityPackage

  [LAMBDA (fileDescr startUpForm)                            (* smL "15-Sep-86 10:52")


          (* * Load the package. See the function AddLoadMenuItem.)



    (
ALLOW.BUTTON.EVENTS
)
    (LET* ((myWindow (
WFROMDS
 (
TTYDISPLAYSTREAM
)))
	   (windowOpen? (
OPENWP
 myWindow)))                (* Let the use know what is going on)

          (printout NIL T "Loading " (for
 x in
 fileDescr thereis
 (
NOT
 (
LISTP
 x)))
		    T)                                       (* Do the load)

          (
DOFILESLOAD
 fileDescr)
          (
EVAL
 startUpForm)                               (* Now remove the load menu item, if you can find it)

          (LET [(topLevelItem (for
 item in
 BackgroundMenuCommands thereis
 (
STREQUAL

										  (
CAR
 item)
										  "Load utility"]
	       (for
 groupItem in
 (
CDAR
 (
LAST
 topLevelItem)) bind
 thisItem
		  eachtime
 [
SETQ
 thisItem
			       (for
 item in
 (
CDAR
 (
LAST
 groupItem))
				  thereis
 (
EQ
 fileDescr
						  (
CADR
 (
CADR
 (
CADR
 (
CADR

									    (
CADR
 (
CADR
 item]
		  when
 thisItem
		  do
 (
DREMOVE
 thisItem (
CAR
 (
LAST
 groupItem)))
		       [if
 (
NULL
 (
CDAR
 (
LAST
 groupItem)))
			   then
 (
DREMOVE
 groupItem (
CDAR
 (
LAST
 topLevelItem]
		       (change
 BackgroundMenu NIL)))       (* Close any TTY window that we may have opened)

          (if
 (
NOT
 windowOpen?)
	      then
 (
CLOSEW
 myWindow])

(LOADMENUITEMSCOMS

  [LAMBDA (GROUP X)                                          (* smL "16-Sep-86 18:37")


          (* * Expand the LOADMENUITEMS filepackage command)



    (
LIST
 (
CONS
 (
QUOTE
 P)
		    (for
 packageDescr in
 X
		       collect
 (if
 (
LITATOM
 packageDescr)
				     then
 [
BQUOTE
 (AddLoadMenuItem
 (
QUOTE
 (\, GROUP))
									 (
QUOTE
 (\, packageDescr]
				   elseif
 (
EQLENGTH
 packageDescr 1)
				     then
 [
BQUOTE
 (AddLoadMenuItem
 (
QUOTE
 (\, GROUP))
									 (
QUOTE

									   (\, (
CAR
 packageDescr]
				   elseif
 (
EQLENGTH
 packageDescr 2)
				     then
 [
BQUOTE
 (AddLoadMenuItem
 (
QUOTE
 (\, GROUP))
									 (
QUOTE

									   (\, (
CAR
 packageDescr)))
									 (
QUOTE

									   (\, (
CADR
 packageDescr]
				   else
 (
ERROR
 "Utility description has too many arguments" 
						   packageDescr])
)
(PUTDEF (QUOTE LOADMENUITEMS) (QUOTE FILEPKGCOMS) (QUOTE ((COM MACRO [(GROUP . X)
								(COMS * (LOADMENUITEMSCOMS
									(QUOTE GROUP)
									(QUOTE X]
							       CONTENTS NILL))))
(PUTPROPS LOADMENUITEMS COPYRIGHT ("Xerox Corporation" 1986))
(DECLARE: DONTCOPY
  (FILEMAP (NIL (831 5541 (AddLoadMenuItem 841 . 3018) (LoadUtilityPackage 3020 . 4588) (
LOADMENUITEMSCOMS 4590 . 5539)))))
STOP