(DEFINE-FILE-INFO PACKAGE "IL" READTABLE "INTERLISP" BASE 10)
(FILECREATED "29-Sep-87 10:45:34" |{EG:PARC:XEROX}<LANNING>LISP>USERS>LOADMENUITEMS.;2| 6849   

      changes to%:  (VARS LOADMENUITEMSCOMS)
                    (FNS AddLoadMenuItem LoadUtilityPackage)

      previous date%: "16-Sep-86 18:44:45" |{EG:PARC:XEROX}<LANNING>LISP>USERS>LOADMENUITEMS.;1|)


(* "
Copyright (c) 1986, 1987 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)
                          (DECLARE%: DONTCOPY (PROP MAKEFILE-ENVIRONMENT 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)                      (* ; "Edited 28-Sep-87 09:55 by smL")

(* ;;; "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 'Misc))
           (fileDescr (MKLIST fileDescr))
           (fileName (for x in fileDescr thereis (NOT (LISTP x))))
           (startUpForm (OR startUpForm `(PROMPTPRINT ',fileName " loaded")))
           (loadForm `'(LISPXEVAL '(LoadUtilityPackage ',fileDescr ',startUpForm) "<mouse event>←"))
           (topLevelItem (OR (for item in BackgroundMenuCommands thereis (STRING-EQUAL (CAR item)
                                                                                "Load utility"))
                             (LET ((topLevelItem (LIST "Load utility" NIL "Load a utility file"
                                                       (LIST 'SUBITEMS))))
                                  (/push BackgroundMenuCommands topLevelItem)
                                  topLevelItem)))
           (groupItem (OR (for item in (CDAR (LAST topLevelItem)) thereis (STRING-EQUAL group
                                                                                 (CAR item)))
                          (LET ((groupList (LIST group NIL "Load a utility file" (LIST '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 `(SETQ ,BackgroundMenu NIL)))))

(LoadUtilityPackage
  (LAMBDA (fileDescr startUpForm)                            (* ; "Edited 28-Sep-87 09:55 by smL")

(* ;;; "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 (STRING-EQUAL (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 'P (for packageDescr in X
                      collect (if (LITATOM packageDescr)
                                  then `(AddLoadMenuItem ',GROUP ',packageDescr)
                                elseif (EQLENGTH packageDescr 1)
                                  then `(AddLoadMenuItem ',GROUP ',(CAR packageDescr))
                                elseif (EQLENGTH packageDescr 2)
                                  then `(AddLoadMenuItem ',GROUP ',(CAR packageDescr)
                                               ',(CADR packageDescr))
                                else (ERROR "Utility description has too many arguments" packageDescr
                                            )))))))
)
(PUTDEF (QUOTE LOADMENUITEMS) (QUOTE FILEPKGCOMS) '((COM MACRO ((GROUP . X)
                                                                (COMS * (LOADMENUITEMSCOMS
                                                                         'GROUP
                                                                         'X)))
                                                         CONTENTS NILL)))
(DECLARE%: DONTCOPY 

(PUTPROPS LOADMENUITEMS MAKEFILE-ENVIRONMENT (:PACKAGE "IL" :READTABLE "INTERLISP" :BASE 10))
)
(PUTPROPS LOADMENUITEMS COPYRIGHT ("Xerox Corporation" 1986 1987))
(DECLARE%: DONTCOPY
  (FILEMAP (NIL (1042 6241 (AddLoadMenuItem 1052 . 3475) (LoadUtilityPackage 3477 . 5352) (
LOADMENUITEMSCOMS 5354 . 6239)))))
STOP