(DEFINE-FILE-INFO PACKAGE "INTERLISP" READTABLE "INTERLISP" BASE 10) (FILECREATED " 2-Aug-2022 10:18:49" {DSK}larry>git-loops>system>LOOPSBROWSE.;3 221717 :CHANGES-TO (FNS \Place-Menu-Group-In-Window) :PREVIOUS-DATE " 6-Nov-91 14:53:35" {DSK}larry>git-loops>system>LOOPSBROWSE.;2) (* ; " Copyright (c) 1983-1988, 1990-1991, 2022 by Venue & Xerox Corporation. ") (PRETTYCOMPRINT LOOPSBROWSECOMS) (RPAQQ LOOPSBROWSECOMS [(CLASSES LatticeBrowser ClassBrowser FileBrowser InstanceBrowser SupersBrowser MetaBrowser) (* ;;; "Generic Lattice browser") (METHODS ClassBrowser.AddRoot ClassBrowser.CareAbout? FileBrowser.Browse FileBrowser.CareAbout? FileBrowser.LoadMasterscope? InstanceBrowser.AddRoot LatticeBrowser.AddRoot LatticeBrowser.BoxNode LatticeBrowser.Browse LatticeBrowser.BrowserObjects LatticeBrowser.ChangeFontSize LatticeBrowser.ChangeFormat LatticeBrowser.ChangeMaxLabelSize LatticeBrowser.Clear LatticeBrowser.ClearLabelCache LatticeBrowser.DeleteFromBrowser LatticeBrowser.DeleteSubtreeFromBrowser LatticeBrowser.DisplayBrowser LatticeBrowser.DisplayNodeHightlights LatticeBrowser.DisplayNodeShading LatticeBrowser.DoCommandInProcess LatticeBrowser.DoSelectedCommand LatticeBrowser.EditObject LatticeBrowser.FlashNode LatticeBrowser.FlipNode LatticeBrowser.GetDisplayLabel LatticeBrowser.GetLabel LatticeBrowser.GetNodeList LatticeBrowser.GetSubs LatticeBrowser.GraphFits LatticeBrowser.HasObject LatticeBrowser.HighlightNode LatticeBrowser.IconTitle LatticeBrowser.LeftSelection LatticeBrowser.LeftShiftSelect LatticeBrowser.MakeParameterMenu LatticeBrowser.MessageFormForProcess LatticeBrowser.MiddleSelection LatticeBrowser.MiddleShiftSelect LatticeBrowser.NewItem LatticeBrowser.NodeRegion LatticeBrowser.ObjNamePair LatticeBrowser.ObjectFromLabel LatticeBrowser.PositionNode LatticeBrowser.Recompute LatticeBrowser.RecomputeInPlace LatticeBrowser.RecomputeLabels LatticeBrowser.RemoveFromBadList LatticeBrowser.RemoveHighlights LatticeBrowser.RemoveShading LatticeBrowser.SaveInIT LatticeBrowser.ShadeNode LatticeBrowser.ShapeToHold LatticeBrowser.Show LatticeBrowser.Shrink LatticeBrowser.SubBrowser LatticeBrowser.TitleSelection LatticeBrowser.UnmarkNodes LatticeBrowser.Unread LatticeBrowser.Update MetaBrowser.CareAbout? SupersBrowser.CareAbout?) (FNS AddMenuWindow BoxPrintString BoxWindowNode BreakStringForBoxing Browse ClearCache DoMenuMethod DualMenu DualSelection DualSubItems FILECLASSES FileBrowse FindSelectedNode FunctionMenuWhenSelectedFn ItemsForType LatticeBrowser.ButtonFn LatticeBrowser.WhenHeldFn LatticeBrowserExpandFn LatticeBrowserIconButtonEventFn LispxSend Menu-Group-Size Repaint-Menu-Window SubItemSelection TreeRoots ReachableNodes! ChildNodes \DeleteSubtree \Menu-Group-Size \Place-Menu-Group-In-Window \PortableGraphNodeID \Remove-Menu-Group-From-Window) (VARS BrowserMargin GRAYSHADE1 GRAYSHADE2 GRAYSHADE3 GRAYSHADE4 MaxLatticeHeight MaxLatticeWidth NestedMenuFlg) (SPECVARS MaxLatticeHeight MaxLatticeWidth) (BITMAPS BrowserIconBM) (* ;;; "Class browser") (METHODS ClassBrowser.AddCategoryMenu ClassBrowser.MessageFormForProcess ClassBrowser.AddNewCV ClassBrowser.AddNewIV ClassBrowser.AddNewMethod ClassBrowser.AddSpecializedMethod ClassBrowser.AddSuper ClassBrowser.BoxNode ClassBrowser.CVDoc ClassBrowser.ClassDoc ClassBrowser.CopyCVTo ClassBrowser.CopyIVTo ClassBrowser.CopyMethodTo ClassBrowser.DefineSubclass ClassBrowser.DeleteCVUsingBrowser ClassBrowser.DeleteClass ClassBrowser.DeleteClassItem ClassBrowser.DeleteIVUsingBrowser ClassBrowser.DeleteMethodUsingBrowser ClassBrowser.DestroyAndRecompute ClassBrowser.EditCategory ClassBrowser.FindWhere ClassBrowser.GetMethodDoc ClassBrowser.GetSubs ClassBrowser.IVDoc ClassBrowser.LeftShiftSelect ClassBrowser.MethodMenu ClassBrowser.MoveCVTo ClassBrowser.MoveIVTo ClassBrowser.MoveMethodTo ClassBrowser.MoveSuperTo ClassBrowser.NewItem ClassBrowser.PrintCategories ClassBrowser.RenameCV ClassBrowser.RenameClass ClassBrowser.RenameIV ClassBrowser.RenameMeth ClassBrowser.RenamePart ClassBrowser.RetireMethod ClassBrowser.SetItNew ClassBrowser.WhereIsCV ClassBrowser.WhereIsIV ClassBrowser.WhereIsMethod) (FNS ClassBrowserMarkChanged UpdateClassBrowsers) (INITVARS (ClassBrowsersThatNeedUpdating NIL) (UpdateClassBrowsers? T)) (FUNCTIONS UpdateClassBrowsers? WithCategories) (GLOBALVARS ClassBrowsersThatNeedUpdating) (SPECVARS UpdateClassBrowsers?) (ADDVARS (MARKASCHANGEDFNS ClassBrowserMarkChanged)) (* ;;; "File browser") (METHODS FileBrowser.AddFile FileBrowser.AddNewMethod FileBrowser.AddSpecializedMethod FileBrowser.AddSubs FileBrowser.AddSubs! FileBrowser.BreakFunction FileBrowser.BrowseFile FileBrowser.ChangeDisplayMode FileBrowser.CollectMethodList FileBrowser.DefineSubclass FileBrowser.EditComs FileBrowser.EditFns FileBrowser.EditInstances FileBrowser.EditMacros FileBrowser.EditRecords FileBrowser.EditVars FileBrowser.File FileBrowser.IconTitle FileBrowser.ListFile FileBrowser.LoadPropFile FileBrowser.LoadAllPropFile FileBrowser.LoadFnsPropFile FileBrowser.MakeFunctionMenu FileBrowser.NewItem FileBrowser.Recompute FileBrowser.SaveFile FileBrowser.SelectFile FileBrowser.SetItNew FileBrowser.SubBrowser FileBrowser.TraceFunction FileBrowser.UnbreakFunction) (FNS FileBrowserMarkChanged) (ADDVARS (MARKASCHANGEDFNS FileBrowserMarkChanged)) (* ;;; "MasterScope methods") (METHODS FileBrowser.AddAnalysisMenu FileBrowser.AnalyzeFile FileBrowser.CallsFunction FileBrowser.CheckMenuItem FileBrowser.CheckFile FileBrowser.ComputeMenuItems FileBrowser.EditMenuItem FileBrowser.ImplementsMethod FileBrowser.OverridesMethod FileBrowser.SelectItemName FileBrowser.SendsMessage FileBrowser.SpecializesMethod FileBrowser.SubstituteMenuItem FileBrowser.UsesCV FileBrowser.UsesIV FileBrowser.UsesItem FileBrowser.UsesLispVar FileBrowser.UsesObject) (FNS UsesMenuWhenSelectedFn) (* ;;; "Instance browser") (METHODS InstanceBrowser.GetSubs InstanceBrowser.NewPath) (* ;;; "Supers browser") (METHODS SupersBrowser.GetSubs) (* ;;; "Meta browser") (METHODS MetaBrowser.GetSubs) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDVARS (NLAMA) (NLAML LispxSend) (LAMA]) (DEFCLASSES LatticeBrowser ClassBrowser FileBrowser InstanceBrowser SupersBrowser MetaBrowser) (DEFCLASS LatticeBrowser (MetaClass Class Edited%:  (* ; "Edited 4-Nov-87 13:43 by jrb:") doc "This is the default metaClass for all classes") (Supers Window) (ClassVariables (BoxLineWidth 1 doc "width to make box for BoxNode") (LocalCommands (EditObject BoxNode Recompute AddRoot) doc "messages that should be sent to browser when item seleted in menu, even if object does understand them" ) (TitleItems ([Recompute (Recompute ((SaveValue SaveInIT "(SavedValue)_ thisBrowser") (Recompute Recompute "Recompute lattice from starting objects") RecomputeLabels (InPlace RecomputeInPlace "Recompute keeping current view in window") (ShapeToHold ShapeToHold "Make window large or small enough to just hold graph" ) (ChangeFontSize ChangeFontSize "Choose a new size Font" ) (Lattice/Tree ChangeFormat "Change format between lattice and tree"] (AddRoot (AddRoot ((AddRoot AddRoot "Add named item to startingList for browser") (RemoveFromBadList RemoveFromBadList "Restore item previously deleted from browser"))) "Add named item to startingList for browser")) doc "Items for menu of selections in title of window") (LeftButtonItems ((BoxNode BoxNode "Draw box around selected node. Unboxed by another BoxNode") (PP PP "Prettyprint selected item")) doc "Menu items for LeftButton seletion -- Value sent as message to object or browser -- see LocalCommands" ) (MiddleButtonItems ((Inspect Inspect "Inspect selected item") (Edit EditObject "Edit selected item") (DeleteFromBrowser DeleteFromBrowser "Do not show item or its subs")) doc "Menu items for MiddleButton seletion -- Value sent as message to object or browser -- see LocalCommands" )) (InstanceVariables (topAlign NIL doc "Flg used to indicate whether graph should be aligned with the top or bottom of the window" ) (title "Lattice browser" doc "Title passed to GRAPHER package") (startingList NIL doc "list of objects used to compute this browser") (goodList NIL doc "limit choices to this set") (badList NIL doc "Don't put in any items on this set") (lastSelectedObject NIL doc "last object selected" DontSave Any) (browseFont #,(Defer (FONTCREATE (QUOTE (HELVETICA 10 BOLD)))) DontSave (Value) FontFamily HELVETICA FontFace BOLD) (LabelMaxLines NIL doc "the maximum number of lines to use in boxed labels -- note that if the label wont fit within the LabelMaxLines and LabelMaxCharsWidth restrictions, it will be truncated" ) (LabelMaxCharsWidth NIL doc "the maximum width for labels -- if label is too big, it will be boxed") (boxedNode NIL doc "last item Boxed, if any") (graphFormat (LATTICE) choices [(HORIZONTAL/LATTICE '(LATTICE)) (VERTICAL/LATTICE '(VERTICAL LATTICE)) (HORIZONTAL/TREE '(COPIES/ONLY)) (VERTICAL/TREE '(VERTICAL COPIES/ONLY] doc "Controls format for laying out graph for GRAPHER") (showGraphFn SHOWGRAPH doc "The function to use to display the graph in the window. This might want to be set to SHOWZOOMGRAPH." ) (width 64 doc "outer width of window, including border") (height 32 doc "outer height of window, including border"))) (DEFCLASS ClassBrowser (MetaClass Class Edited%:  (* ; "Edited 7-Mar-88 18:55 by jrb:") doc "A window containing a lattice displaying classes.") (Supers IndexedObject LatticeBrowser) (ClassVariables (TitleItems #,($AV AppendSuperValue ((SQV0.%:F5.C38.9W8 . 15)) (localState (("Add Category Menu" AddCategoryMenu "Add an attached menu for changing the viewed method categories of this browser")))) ) (LeftButtonItems ((PrintSummary (PrintSummary (PrintCategories PP PP! PPV! PPMethod MethodSummary PrintSummary)) "PrintSummary of class") ("Doc (ClassDoc)" (ClassDoc (ClassDoc (MethodDoc GetMethodDoc) IVDoc CVDoc)) "Documentation for Class, Methods, IVs and CVs Class is default") ("WhereIs (WhereIsMethod)" (WhereIsMethod (WhereIsIV WhereIsCV WhereIsMethod)) "Find location of iv, cv, or method") (DeleteFromBrowser (DeleteFromBrowser (DeleteFromBrowser DeleteSubtreeFromBrowser)) "Remove from browser -- does not affect class itself.") (SubBrowser SubBrowser "Make a subBrowser on this class") (TypeInName Unread "Put class name in typein buffer"))) (MiddleButtonItems ((Box/UnBoxNode BoxNode "Boxing this node makes it the target for Move and/or copy operations" ) ("Methods (EditMethod)" (EditMethod [(EditMethod EditMethod "Edit method selected from menu" ) (EditMethod! EM! "Edit method selected from menu, making it local if necessary" ) (EditMethodObject EditMethodObject "Edit the object representing the method" ) (MethodMenu MethodMenu "Produce a menu for editing methods of this class" ) (EditCategory (EditCategory (EditCategory ChangeMethodCategory CategorizeMethods) )) (BreakMethod (BreakMethod (BreakMethod TraceMethod UnbreakMethod ] "Edit method of class selected from Menu" ) ("Edit, break, or unbreak a method." NIL)) ("Add (AddMethod)" (AddNewMethod (("AddIV" AddNewIV "Add a new IV to the class") ("AddCV" AddNewCV "Add a new CV to the class") ("AddMethod" AddNewMethod "Add a new method to the class" ) ("DefRSM" DefRSM "Add a new ruleset method to the class" ) (SpecializeMethod AddSpecializedMethod "Add a specialization of a selected method" ) AddSuper ("SpecializeClass" DefineSubclass "Define a specialized subclass" ) ("NewInstance" SetItNew "Set (SavedValue) to a new instance of the class" )) NIL) "Add Method (default) or add other items to class") ("Delete (DeleteMethod)" (DeleteMethodUsingBrowser ((DeleteIV DeleteIVUsingBrowser "Delete IV from selected class" ) (DeleteCV DeleteCVUsingBrowser "Delete CV from selected class" ) (DeleteMethod DeleteMethodUsingBrowser "Delete Method from selected class" ) DeleteClass)) "Delete one of Methods IVs CVs or the class itself") ("Move (MoveMethodTo)" (MoveMethodTo (MoveIVTo MoveCVTo MoveMethodTo MoveSuperTo MoveToFile MoveToFile!))) ("Copy (CopyMethodTo)" (CopyMethodTo (CopyIVTo CopyCVTo CopyMethodTo))) ("Rename (RenameMethod)" (RenameMeth (RenameIV RenameCV ("RenameMethod" RenameMeth "Change the name of a selected method" ) (RetireMethod RetireMethod "Rename method Selector to OldSelector" ) RenameClass)) "Rename some part of the class") ("Edit (EditClass)" (EditObject (("EditClass" EditObject "Edit the class") ("EditClass!" Edit! "Edit class showing inherited info" ) ("InspectClass" 'Inspect "Inspect selected class"))) "Edit class"))) (LocalCommands (AddNewMethod AddNewIV AddNewCV AddSpecializedMethod CopyMethodTo CopyIVTo CopyCVTo BoxNode ClassDoc CVDoc DefineSubclass DeleteClassItem DeleteIV EditObject FindWhere FlipNode IVDoc GetMethodDoc MoveMethodTo MoveIVTo MoveCVTo MoveSuperTo Recompute RenamePart SubBrowser Unread))) (InstanceVariables (title "Class browser") (viewingCategories (Public) doc "List of categories that should be considered when displaying class methods"))) (DEFCLASS FileBrowser (MetaClass Class doc "This implements a browser for multiple files." Edited%: (* smL "21-May-86 13:14")) (Supers ClassBrowser) (ClassVariables (LocalCommands #,($AV AppendSuperValue ((YTV0.%:F5.C38.nT? . 455)) (localState (DefMethod))) ) (LeftButtonItems #,($AV AppendSuperValue ((GSV0.%:F5.C38.^n9 . 11)) (localState ((AddSubs (AddSubs ((AddSubs AddSubs "Add subs of this class to nonFileClasses") (AddSubs! AddSubs! "Add subs, at all levels, of this class to nonFileClasses"))) "Add subs of this class to nonFileClasses")))) ) (MiddleButtonItems #,($AV AppendSuperValue ((YTV0.%:F5.C38.nT? . 460)) (localState (("Uses IV" (UsesIV (UsesIV UsesCV UsesObject UsesLispVar SendsMessage (ImplementsMethod (ImplementsMethod (ImplementsMethod OverridesMethod SpecializesMethod))) CallsFunction)) "Show who uses an IV")))) ) (TitleItems #,($AV AppendSuperValue ((JNW0.%:F5.C38.D?8 . 10)) (localState (("Change display mode" (ChangeDisplayMode (("Change display mode" ChangeDisplayMode "Select one of selectedFile associatedFiles all") ("Add file to browser" AddFile "Associate additional file with browser.") ("Select File" SelectFile "Change Default file for Display and filing."))) "Select one of selectedFile associatedFiles all") ("Uses IV?" (UsesIV (UsesIV UsesCV UsesObject UsesLispVar (ImplementsMethod (ImplementsMethod (ImplementsMethod OverridesMethod SpecializesMethod))) SendsMessage CallsFunction AnalyzeFile CheckFile)) "Use MasterScope to show who uses an IV") ("Edit File Coms" (EditComs (("Edit Functions" (EditFns (EditFns MakeFunctionMenu BreakFunction TraceFunction UnbreakFunction)) "Edit a selected function or add a new one") EditComs EditMacros EditRecords EditVars EditInstances)) "Edit the Coms for the file") ("CLEANUP file" (SaveFile (("CLEANUP file" SaveFile "Do (FILES?) and then CLEANUP the file") ("Hardcopy file" ListFile "Do a LISTFILES1 on the selected file") ("Load PROP file" LoadPropFile "Load the file with LDFLG = PROP"))) "Do (FILES?) and then CLEANUP the file")))) doc "Items for menu of selections in title of window")) (InstanceVariables (title "FileBrowser" doc "Title of browser") (width 100) (selectedFile NIL doc "Name of cirrent default file for display and addition of objects. fileComs property is atom for fileComs" fileComs NIL) (associatedFiles NIL doc "List of files currently being browsed") (displayMode selectedFile doc "One of selectedFile, associatedFiles, or all") (nonFileClasses NIL doc "classes which should be added to browser, but are no on file. Must be exisiting classes" ) (msMode onFile doc "One of onFile, known, or any"))) (DEFCLASS InstanceBrowser (MetaClass Class doc "Follows the downward lattice in object named in subIV. If subIV is changed after display, will show the newly defined alternative lattice starting at the same starting points" Edited%: (* smL "29-Sep-86 19:31")) (Supers LatticeBrowser) (ClassVariables (TitleItems ((Recompute 'Recompute "Recompute lattice from starting objects") (NewPath 'NewPath "Change name of sub to be followed in computing lattice.") (AddRoot 'AddRoot "Add named item to startingList for browser") (SaveValue 'SaveInIT "(SavedValue)_ thisBrowser")) doc "Items for menu of selections in title of window")) (InstanceVariables (subIV NIL doc "Name of instance variable which provides names and/or pointers to subobjects" ) (title "Instance browser"))) (DEFCLASS SupersBrowser (MetaClass Class Edited%: (* smL "11-Jun-86 13:18") doc "Browses upwards from a class to all of its supers.") (Supers ClassBrowser) (InstanceVariables (title "Supers browser"))) (DEFCLASS MetaBrowser (MetaClass Class doc "Runs through the meta classes of a class" Edited%: (* smL "11-Jun-86 13:18")) (Supers ClassBrowser) (InstanceVariables (title "MetaClass browser"))) (* ;;; "Generic Lattice browser") (\BatchMethodDefs) (METH ClassBrowser AddRoot (newItem) "Checks that newItem is a class before adding it to the browser" (category (LatticeBrowser))) (METH ClassBrowser CareAbout? (object) "We care if object is a class, is not on our badList, and is a subclass of something on our startingList" (category (LatticeBrowser))) (METH FileBrowser Browse (fileName) "Catches Browse messages and lets user BrowseFile" (category (LatticeBrowser))) (METH FileBrowser CareAbout? (object) "We care if object is a class, is not on our badList, and is on our startingList or our nonFileClasses" (category (LatticeBrowser))) (METH FileBrowser LoadMasterscope? NIL "Tests to see if LOOPS Masterscope is loaded and asks to load it" (category (Masterscope FileBrowser) )) (METH InstanceBrowser AddRoot NIL NIL (category (LatticeBrowser))) (METH LatticeBrowser AddRoot (newItem) "Add a named item to the starting list of the browser" (category (LatticeBrowser))) (METH LatticeBrowser BoxNode (object objName unboxPrevious) "Puts a box around the node in the graph representing the object." (category (LatticeBrowser))) (METH LatticeBrowser Browse (browseList windowOrTitle goodList position) "Call Show and then shape to hold and move for first time" (category (LatticeBrowser))) (METH LatticeBrowser BrowserObjects NIL "Return a list of all the objects shown in the browser" (category (LatticeBrowser))) (METH LatticeBrowser ChangeFontSize (size) "Change the font size from whatever it is to size" (category (LatticeBrowser))) (METH LatticeBrowser ChangeFormat (format) "Change format between Lattice and Tree" (category (LatticeBrowser))) (METH LatticeBrowser ChangeMaxLabelSize (newMaxWidth newMaxLines) "change the max label dimensions and redisplay the nodes -- if new size is NULL, don't change" (category (LatticeBrowser))) (METH LatticeBrowser Clear NIL "empty the window of active regions, return the window" (category (Window))) (METH LatticeBrowser ClearLabelCache (objects) "Delete the cached label for these items" (category (LatticeBrowser))) (METH LatticeBrowser DeleteFromBrowser (obj objname) "Place on badList for Browser" (category (LatticeBrowser))) (METH LatticeBrowser DeleteSubtreeFromBrowser (obj objname) "Delete this node and any of its subnodes from the graph" (category (LatticeBrowser))) (METH LatticeBrowser DisplayBrowser NIL "New method template" (category (LatticeBrowser))) (METH LatticeBrowser DisplayNodeHightlights (node shade boxWidth) "New method template" (category (LatticeBrowser))) (METH LatticeBrowser DisplayNodeShading (node shade) "New method template" (category (LatticeBrowser))) (METH LatticeBrowser DoCommandInProcess (obj selector args node) "Does a lattice command in a separate process. Grays out the node at the beginning of the command, and ungrays it when the command completes." (category (LatticeBrowser))) (METH LatticeBrowser DoSelectedCommand (command obj objName) "Do the selected command or forwards it to the object" (category (LatticeBrowser))) (METH LatticeBrowser EditObject (object objName args) "Call editor with commands args" (category (LatticeBrowser))) (METH LatticeBrowser FlashNode (node N flashTime leaveFlipped?) "Flip node N times" (category (LatticeBrowser))) (METH LatticeBrowser FlipNode (object) "Inverts the video around the node in the graph representing the object" (category ( LatticeBrowser ))) (METH LatticeBrowser GetDisplayLabel (object) "get the display label. use the cache if it provides the answer; if not, and maxLabelWidth is set, use it to compute the appropriate bit map and then cache the result." (category (LatticeBrowser))) (METH LatticeBrowser GetLabel (object) "Get a label for an object to be displayed in the browser." (category (LatticeBrowser))) (METH LatticeBrowser GetNodeList (browseList goodList) "Compute the node data structures of the tree starting at browseList. If goodList is given, only include elements of it. If goodList=T make it be browseList." (category (LatticeBrowser))) (METH LatticeBrowser GetSubs (object) "Gets a set of subs from an object for browsing" (category (LatticeBrowser))) (METH LatticeBrowser GraphFits (snugly?) "Tests if graph fits in region" (category (LatticeBrowser))) (METH LatticeBrowser HasObject (object) "Check object in grapher nodes, and return if it is one of them" (category (LatticeBrowser))) (METH LatticeBrowser HighlightNode (object width shade) "hightlight a node by surronding it with a shaded box" (category (LatticeBrowser))) (METH LatticeBrowser IconTitle NIL "Compute the icont title for this browser" (category (LatticeBrowser))) (METH LatticeBrowser LeftSelection NIL "Move object if CTRL down. Do LeftShiftSelect if SHIFT down, else choose from LeftButtonItems" (category (Window))) (METH LatticeBrowser LeftShiftSelect (object objname) "Called when item is selected with left key and LSHIFT is down" (category (LatticeBrowser))) (METH LatticeBrowser MakeParameterMenu (menu test-form change-form) "Create a menu for viewing a parameter of self" (category (LatticeBrowser))) (METH LatticeBrowser MessageFormForProcess (obj selector args) "Create a form to evaluate in a new process that will send the obj the selector message with the given args" (category (LatticeBrowser))) (METH LatticeBrowser MiddleSelection NIL "This function called from the GRAPHER package when a node is selected with the middle mouse button. If no node is selected then just returns." (category (Window))) (METH LatticeBrowser MiddleShiftSelect (object objname) "Called when item is selected with middle key and LSHIFT is down SendInTtyProcess is so this is done in the TTY process" (category (LatticeBrowser))) (METH LatticeBrowser NewItem (newItem) "Return Object. Prompt for it if needed." (category (LatticeBrowser))) (METH LatticeBrowser NodeRegion (object) "what region does the object occupy in the display stream?" (category (LatticeBrowser))) (METH LatticeBrowser ObjNamePair (objOrName) "Make a pair (object . objName) where objName is label to be used in browser" (category ( LatticeBrowser ))) (METH LatticeBrowser ObjectFromLabel (label) "What object has this label?" (category (LatticeBrowser))) (METH LatticeBrowser PositionNode (object windowX windowY) "scrolls the window so that the node is in the given position of the window. If windowX or windowY is a FLOATP, it it taken to be a window-relative postion; if a FIXP, it is a window-absolute position." (category (LatticeBrowser))) (METH LatticeBrowser Recompute (dontReshapeFlg) "Recompute the browseGraph in the same window" (category (LatticeBrowser))) (METH LatticeBrowser RecomputeInPlace NIL "recompute the graph, maintaining the current position" (category (LatticeBrowser))) (METH LatticeBrowser RecomputeLabels NIL "recompute the graph, including the labels" (category (LatticeBrowser))) (METH LatticeBrowser RemoveFromBadList NIL "Remove an item from BadList to allow it to be displayed once again" (category (LatticeBrowser) )) (METH LatticeBrowser RemoveHighlights NIL "gets rid of all highlighting in the lattice" (category (LatticeBrowser))) (METH LatticeBrowser RemoveShading NIL "gets rid of all shading in the lattice" (category (LatticeBrowser))) (METH LatticeBrowser SaveInIT NIL "A Browser command to save self in SavedValue" (category (LatticeBrowser))) (METH LatticeBrowser ShadeNode (object shade) "shade the background of a node" (category (LatticeBrowser))) (METH LatticeBrowser ShapeToHold NIL "Shape the browse window to just hold the nodes with BrowserMargin to spare" (category ( LatticeBrowser ))) (METH LatticeBrowser Show (browseList windowOrTitle goodList) "Show the items and their subs on a browse window." (category (LatticeBrowser))) (METH LatticeBrowser Shrink (towhat iconPos expandFn) "the default icon should be used if there is no explicit icon given" (category (Window))) (METH LatticeBrowser SubBrowser (obj objName) "Create a subbrowser on selected object" (category (LatticeBrowser))) (METH LatticeBrowser TitleSelection NIL "Do TitleItems if selected in title area. Replaces TitleSelection in Window because this one does evaluation in TTY process, and saves events on history" (category (Window))) (METH LatticeBrowser UnmarkNodes NIL "clear the graph nodes, removing all shading and highlighting" (category (LatticeBrowser))) (METH LatticeBrowser Unread (object objName) "Unread name into system buffer - or if no node, unread the entire graph" (category ( LatticeBrowser ))) (METH LatticeBrowser Update NIL "Make sure the graph gets updated too" (category (Window))) (METH MetaBrowser CareAbout? (object) "We care if object is a class which is a subclass of Class; yes, this is a hack" (category ( LatticeBrowser ))) (METH SupersBrowser CareAbout? (object) "We care if object is a class, is not on our badList, and is a superclass of something on our startingList" (category (LatticeBrowser))) (Method ((ClassBrowser AddRoot) self newItem) "Checks that newItem is a class before adding it to the browser" (OR newItem (SETQ newItem (_ self NewItem newItem))) (COND ((NULL newItem) (_ self PromptPrint "Nothing Added To Browser")) ((NOT (Class? newItem)) (_ self PromptPrint "That's not a class!")) (T (_Super self AddRoot newItem)))) (Method ((ClassBrowser CareAbout?) self object) "We care if object is a class, is not on our badList, and is a subclass of something on our startingList" [COND ((AND (\Loading-File?) (FMEMB self ClassBrowsersThatNeedUpdating)) (* ;; "This browser is going to get updated already, so it doesn't care") NIL) ((OR (NOT (Class? object)) (FMEMB object (@ badList))) NIL) ((OR (FMEMB object (@ goodList)) (for c in (@ startingList) thereis (_Try object Subclass c]) (Method ((FileBrowser Browse) self fileName) "Catches Browse messages and lets user BrowseFile" (if (LoopsHelp "The method to initialize a FileBrowser is BrowseFile, not Browse. Type RETURN T to browse this file:" fileName) then (_ self BrowseFile fileName))) (Method ((FileBrowser CareAbout?) self object) "We care if object is a class, is not on our badList, and is on our startingList or our nonFileClasses" [COND ((AND (\Loading-File?) (FMEMB self ClassBrowsersThatNeedUpdating)) (* ;; "This browser is going to get updated already, so it doesn't care") NIL) ((OR (NOT (Class? object)) (FMEMB object (@ badList))) NIL) ((OR (FMEMB object (@ goodList)) (FMEMB object (@ nonFileClasses)) (for c in (@ startingList) thereis (_Try object Subclass c]) (Method ((FileBrowser LoadMasterscope?) self) "Tests to see if LOOPS Masterscope is loaded and asks to load it" (if (NOT (GETD 'LoopsMethodMSGETDEF)) then (_ self PromptPrint "Masterscope is not loaded yet ") (if (NiceMenu '((YES T) (NO NIL)) "Load Masterscope?") then (FILESLOAD (FROM VALUEOF LOOPSLIBRARYDIRECTORY) LOOPSMS) T) else T)) (Method ((InstanceBrowser AddRoot) self newItem) "Checks that newItem is an instance before adding it to the browser" (OR newItem (SETQ newItem (_ self NewItem newItem))) (COND ((NULL newItem) (_ self PromptPrint "Nothing Added To Browser")) ((NOT (Instance? newItem)) (_ self PromptPrint "That's not an instance!")) (T (_Super self AddRoot newItem)))) (Method ((LatticeBrowser AddRoot) self newItem) (* ; "smL 11-Dec-86 10:23") "Add a named item to the starting list of the browser" (* ;; "Go get newItem if it wasn't supplied") (OR newItem (SETQ newItem (_ self NewItem newItem))) (* ;; "Map newItem to an object if it's a symbol") [LET ((newObject (if (AND newItem (CL:SYMBOLP newItem)) then ($! newItem) else newItem))) (COND ((NULL newItem) (_ self PromptPrint "Nothing Added To Browser") NIL) ((NOT (Object? newObject)) (_ self PromptPrint "That's not an object!") NIL) (T (if (_ self HasObject newObject) then NIL else (pushnew (@ startingList) newObject) (if (@ goodList) then (pushnew (@ goodList) newObject)) (_@ badList (DREMOVE newObject (@ badList))) (_ self Recompute) self]) (Method ((LatticeBrowser BoxNode) self object objName unboxPrevious) (* ; "smL 8-Apr-87 18:34") "Puts a box around the node in the graph representing the object." (_@ boxedNode (COND ([NULL (Object? (SETQ object ($! object] (@ boxedNode)) ((NULL (@ boxedNode)) (_ self HighlightNode object (@ |::BoxLineWidth|)) object) ((EQ object (@ boxedNode)) (* Invert state if given boxnode a  second time) (_ self HighlightNode object 'INVERT) NIL) (T (* If there was a previously boxed  node, remove the box from around it) (AND unboxPrevious (_ self HighlightNode (@ boxedNode) 'INVERT)) (_ self HighlightNode object (@ |::BoxLineWidth|)) object)))) (Method ((LatticeBrowser Browse) self browseList windowOrTitle goodList position) (* ; "dgb: 11-Sep-84 07:24") "Call Show and then shape to hold and move for first time" (_ self Show browseList windowOrTitle goodList) (_ self ShapeToHold) (_ self Move position)) (Method ((LatticeBrowser BrowserObjects) self) (* ; "dgb: 28-May-84 12:58") "Return a list of all the objects shown in the browser" (for node in (fetch GRAPHNODES of (WINDOWPROP (@ window) 'GRAPH)) when (NLISTP (CAR node)) collect (CAR node))) (Method ((LatticeBrowser ChangeFontSize) self size) (* ; "smL 13Dec-84 13:04") "Change the font size from whatever it is to size" [OR size (SETQ size (MENU (COND ((type? MENU (GETTOPVAL 'MenuSize)) MenuSize) (T (SETTOPVAL 'MenuSize (create MENU TITLE _ "Select Desired Size" CHANGEOFFSETFLG _ T ITEMS _ '((Abort NIL) 8 10 12 16] (SETQ size (FONTCREATE (LIST (@ browseFont%:,FontFamily) size (@ browseFont%:,FontFace)) NIL NIL NIL NIL T)) (* ;; "If size is NIL now, couldn't find the font") (if size then (_@ browseFont size) (* clear out the label cache!) (_ self RecomputeLabels) else (PROMPTPRINT "Sorry, no font of that size!"))) (Method ((LatticeBrowser ChangeFormat) self format) (* ; "dgb: 21-Apr-84 19:52") "Change format between Lattice and Tree" (COND ((LISTP format) (_@ graphFormat format)) ([SETQ format (MENU (create MENU ITEMS _ (@ graphFormat%:,choices)] (_@ graphFormat format))) (_ self Recompute)) (Method ((LatticeBrowser ChangeMaxLabelSize) self newMaxWidth newMaxLines) (* ; "smL 13-Dec-84 13:05") "change the max label dimensions and redisplay the nodes -- if new size is NULL, don't change" (if newMaxLines then (change (@ LabelMaxLines) newMaxLines)) (if newMaxWidth then (change (@ LabelMaxCharsWidth) newMaxWidth)) (* ; "clear out the label cache") (_ self RecomputeLabels)) (Method ((LatticeBrowser Clear) self) (* ; "edited: 2-Jul-84 13:43") "empty the window of active regions, return the window" (WINDOWPROP (@ window) 'GRAPH NIL) (_Super self Clear) (@ window)) (Method ((LatticeBrowser ClearLabelCache) self objects) (* ; "smL 5-Dec-85 12:02") "Delete the cached label for these items" (if (LISTP objects) then (for item in objects bind cachedLabel do (SETQ cachedLabel (ASSOC item (@ menus%:,objectLabels) )) (if cachedLabel then (change (@ menus%:,objectLabels) (DREMOVE cachedLabel DATUM)) else)) elseif (EQ objects T) then (change (@ menus%:,objectLabels) NIL) else (LET [(cachedLabel (ASSOC objects (@ menus%:,objectLabels)] (if cachedLabel then (change (@ menus%:,objectLabels) (DREMOVE cachedLabel DATUM)) else)))) (Method ((LatticeBrowser DeleteFromBrowser) self obj objname)(* ; "smL 5-Aug-86 16:50") "Place on badList for Browser" (pushnew (@ badList) obj) (_ self Recompute)) (Method ((LatticeBrowser DeleteSubtreeFromBrowser) self obj objname) (* ; "smL 5-Jun-86 14:14") "Delete this node and any of its subnodes from the graph" (\DeleteSubtree self (WINDOWPROP (@ window) 'GRAPH) obj) (pushnew (@ badList) obj) (_ self Recompute)) (Method ((LatticeBrowser DisplayBrowser) self) (* ; "smL 29-Sep-86 12:15") "New method template" [LET [(NODELST (AND (@ startingList) (_ self GetNodeList (@ startingList) (@ goodList))] (* window should be invert so that  links etc. can be erased) (DSPOPERATION 'INVERT (@ window)) (COND (NODELST (APPLY* (@ showGraphFn) (LAYOUTGRAPH NODELST (TreeRoots NODELST) (@ graphFormat) (@ browseFont)) (@ window) NIL NIL (@ topAlign)) (* Kludge%: put the window back to make sure that the button event fns are  correct) (change (@ window) DATUM) (WINDOWPROP (@ window) 'TITLE (@ title)) (* kludge%: because GRAPHER adds its  own COPYBUTTONEVENTFN) (WINDOWPROP (@ window) 'COPYBUTTONEVENTFN NIL)) (T (_ self Clear)]) (Method ((LatticeBrowser DisplayNodeHightlights) self node shade boxWidth) (* ; "smL 13-Dec-85 15:15") "New method template" (RESET/NODE/BORDER node (COND (shade (LIST boxWidth shade)) (T boxWidth)) (@ window))) (Method ((LatticeBrowser DisplayNodeShading) self node shade)(* ; "smL 13-Dec-85 15:13") "New method template" (RESET/NODE/LABELSHADE node (OR shade WHITESHADE) (@ window))) (Method ((LatticeBrowser DoCommandInProcess) self obj selector args node) (* ; "smL 17-Sep-86 17:46") "Does a lattice command in a separate process. Grays out the node at the beginning of the command, and ungrays it when the command completes." (EVAL.IN.TTY.CONTEXT [if node then `(LET ((*PACKAGE* (_ ,self MousePackage)) (*READTABLE* (_ ,self MouseReadtable))) (_ ,self ShadeNode ,node ,GRAYSHADE2) (LispxSend ,(_ self MessageFormForProcess obj selector args)) (_ ,self ShadeNode ,node ,WHITESHADE)) else `(LET ((*PACKAGE* (_ ,self MousePackage)) (*READTABLE* (_ ,self MouseReadtable))) (LispxSend ,(_ self MessageFormForProcess obj selector args)] selector)) (Method ((LatticeBrowser DoSelectedCommand) self command obj objName) (* ; "smL 17-Sep-86 17:49") "Do the selected command or forwards it to the object" [if command then (* Take care of being passed in a dummy node from browser in Lattice mode.  -  Dummy nodes are indicated by having the object in a list) (LET ((args (if (LISTP command) then (CDR command) else NIL)) (command (if (LISTP command) then (CAR command) else command)) (obj (if (LISTP obj) then (CAR obj) else obj)) (objName (if (LISTP obj) then (GetObjectName (CAR obj)) else objName))) (COND ((AND (NOT (FMEMB command (@ |::LocalCommands|))) (_ obj Understands command)) (_ self DoCommandInProcess obj command args)) (T (_ self DoCommandInProcess self command `(,obj ,objName ,@args))]) (Method ((LatticeBrowser EditObject) self object objName args) (* ; "dgb: 2-MAR-83 10:58") "Call editor with commands args" (_ object Edit args)) (Method ((LatticeBrowser FlashNode) self node N flashTime leaveFlipped?) (* ; "smL 12-Dec-84 16:09") "Flip node N times" [LET [(nodestruct (FASSOC (COND ((LITATOM node) (SETQ node (GetObjectRec node))) (T node)) (fetch GRAPHNODES of (WINDOWPROP (@ window) 'GRAPH] (if nodestruct then (for i from 1 to (OR N 3) do (FLIPNODE nodestruct (@ window)) (DISMISS (OR flashTime 300)) (FLIPNODE nodestruct (@ window)) (DISMISS (OR flashTime 300))) (if leaveFlipped? then (_ self FlipNode node)]) (Method ((LatticeBrowser FlipNode) self object) (* ; "smL 13-Dec-85 15:18") "Inverts the video around the node in the graph representing the object" [LET [(node (FASSOC (COND ((LITATOM object) (SETQ object (GetObjectRec object))) (T object)) (fetch GRAPHNODES of (WINDOWPROP (@ window) 'GRAPH] (* For some squirly reason this doesn't work.  Need to check if anyone else calls DisplayNodeShading...  (AND node (_ self DisplayNodeShading node  (INVERTED/SHADE/FOR/GRAPHER (fetch NODELABELSHADE of node))))) (AND node (FLIPNODE node (@ window)]) (Method ((LatticeBrowser GetDisplayLabel) self object) (* ; "smL 15-Oct-85 11:34") "get the display label. use the cache if it provides the answer; if not, and maxLabelWidth is set, use it to compute the appropriate bit map and then cache the result." (LET [(cachedLabel (ASSOC object (@ menus%:,objectLabels)] (if cachedLabel then (CDR cachedLabel) else (LET [(newLabel (BoxPrintString (_ self GetLabel object) (@ LabelMaxCharsWidth) (@ LabelMaxLines) (@ browseFont)] (if (LISTP newLabel) then (* GRAPHER dies if the label is a list) (SETQ newLabel (MKSTRING newLabel))) (change (@ menus%:,objectLabels) (CONS (CONS object newLabel) (if (NoValueFound DATUM) then NIL else DATUM))) newLabel)))) (Method ((LatticeBrowser GetLabel) self object) (* ; "smL 10-Dec-84 16:11") "Get a label for an object to be displayed in the browser." (GetObjectName object)) (Method ((LatticeBrowser GetNodeList) self browseList goodList) (* ; "smL 21-Mar-85 14:09") "Compute the node data structures of the tree starting at browseList. If goodList is given, only include elements of it. If goodList=T make it be browseList." (DECLARE (GLOBALVARS WHITESHADE)) (COND ((EQ goodList T) (SETQ goodList browseList))) (PROG (subs pair node [oldNodes (fetch GRAPHNODES of (WINDOWPROP (@ window) 'GRAPH] (objList (CONS))) (* ;; "first make objList which is a list of pairs (object . objName). objName will be used as a title for a node in the browser. This structure will be replaced by a graphNode when it is processed. The nodeID of the graphNode will be the object, and the label will be the name.") (for objOrName in browseList do (AND (SETQ pair (_ self ObjNamePair objOrName)) (NOT (FASSOC (CAR pair) (CAR objList))) (TCONC objList pair))) (* ;; "Now MAP ON list so pair can be replaced by graphNode") (for pair name obj subObjs on (CAR objList) when (NLISTP (SETQ name (CDAR pair))) do (SETQ subObjs (CONS)) [for sub objPair obj1 in (_ self GetSubs (SETQ obj (CAAR pair))) do (* ;; "ObjNamePair returns NIL for destroyed objects. include only members of goodList in subs if given. Add to objList only once") (SETQ obj1 (COND ((EQ (CAR sub) 'Link% Parameters) (CADR sub)) (T sub))) (COND ((SETQ objPair (_ self ObjNamePair obj1)) (COND ((NOT (FASSOC obj1 (CAR objList))) (TCONC objList objPair))) (TCONC subObjs sub] [RPLACA pair (SETQ node (OR (FASSOC obj oldNodes) (create GRAPHNODE NODEID _ obj NODEBORDER _ (PROGN (LIST (ADD1 (@ |::BoxLineWidth|) ) WHITESHADE) (* ; "This makes graphs too big -- TAL") NIL] (replace TONODES of node with (CAR subObjs)) (replace NODELABEL of node with name) (replace NODEFONT of node with (@ browseFont)) (replace NODEWIDTH of node with NIL) (replace NODEHEIGHT of node with NIL)) (RETURN (CAR objList)))) (Method ((LatticeBrowser GetSubs) self object) (* ; "dgb: 26-SEP-82 17:17") "Gets a set of subs from an object for browsing" (COND ((_ object HasIV 'subs) (* If the object has an IV called subs  then use the contents of that) (@ object subs)))) (Method ((LatticeBrowser GraphFits) self snugly?) (* ; "smL 24-Apr-86 15:00") "Tests if graph fits in region" [LET ((window (@ window))) (LET [(width 0) (height 0) (region (WINDOWPROP window 'REGION)) [nodes (fetch GRAPHNODES of (WINDOWPROP window 'GRAPH] (fontheight*2 (ITIMES 2 (FONTHEIGHT (@ browseFont)] [COND (nodes [SETQ width (WIDTHIFWINDOW (IDIFFERENCE (MAX/RIGHT nodes) (MIN/LEFT nodes)) (WINDOWPROP window 'BORDER] (SETQ height (HEIGHTIFWINDOW (IDIFFERENCE (MAX/TOP nodes) (MIN/BOTTOM nodes)) (WINDOWPROP window 'TITLE) (WINDOWPROP window 'BORDER] (AND (NOT (IGREATERP width (fetch WIDTH of region))) (NOT (IGREATERP height (fetch HEIGHT of region))) (if snugly? then (* ;; "and not too big (space left is more than 2 browseFont heights)") (AND (ILESSP (IDIFFERENCE (fetch WIDTH of region) width) fontheight*2) (ILESSP (IDIFFERENCE (fetch HEIGHT of region) height) fontheight*2)) else T]) (Method ((LatticeBrowser HasObject) self object) (* ; "dgb: 28-May-84 12:56") "Check object in grapher nodes, and return if it is one of them" (AND [FASSOC (GetObjectRec object) (fetch GRAPHNODES of (WINDOWPROP (@ window) 'GRAPH] T)) (Method ((LatticeBrowser HighlightNode) self object width shade) (* ; "smL 13-Dec-85 15:16") "hightlight a node by surronding it with a shaded box" (LET [(node (FASSOC (COND ((LITATOM object) (SETQ object (GetObjectRec object))) (T object)) (fetch GRAPHNODES of (WINDOWPROP (@ window) 'GRAPH] (AND node (_ self DisplayNodeHightlights node shade width)))) (Method ((LatticeBrowser IconTitle) self) (* ; "edited: 18-Jan-85 15:35") "Compute the icont title for this browser" (LET [(item (CAR (@ startingList)] (if (NULL item) then "Browser" else (_ self GetLabel item)))) (Method ((LatticeBrowser LeftSelection) self) (* ; "smL 14-Jan-87 13:20") "Move object if CTRL down. Do LeftShiftSelect if SHIFT down, else choose from LeftButtonItems" [LET ((window (@ window))) (COND ((MoveDown?) (RESETLST (RESETSAVE NIL (LIST (FUNCTION DSPOPERATION) (DSPOPERATION 'INVERT window) window)) (GETMOUSESTATE) (* Here to move a node.) (DSPOPERATION 'INVERT window) (EDITMOVENODE window))) (T (* Here if left button depressed but  not control.) (LET (objName (latticeBrowser self) (object (FindSelectedNode window))) (DECLARE (SPECVARS object latticeBrowser))(* SPECVARS for whenHeldFn) [COND ((LISTP object) (SETQ object (CAR object] (COND ((NOT (NULL object)) (SETQ objName (GetObjectName object)) (change (@ lastSelectedObject) object))) (GETMOUSESTATE) (COND ((CopyDown?) (while (CopyDown?) do (BLOCK)) (_ self Unread object objName)) ((NULL object) NIL) ((MetaDown?) (_ latticeBrowser LeftShiftSelect object objName)) (T (LET ((selector (_ self LeftChoice))) (COND (selector (_ latticeBrowser DoSelectedCommand selector object objName)]) (Method ((LatticeBrowser LeftShiftSelect) self object objname) (* ; "dgb: 28-SEP-82 11:31") "Called when item is selected with left key and LSHIFT is down" (_ object PP!)) (Method ((LatticeBrowser MakeParameterMenu) self menu test-form change-form) (* ; "smL 17-Sep-86 18:11") "Create a menu for viewing a parameter of self" [replace WHENSELECTEDFN of menu with (FUNCTION (LAMBDA (item menu) (LET [(self (GETMENUPROP menu 'self)) (test-form (GETMENUPROP menu 'test-form)) (change-form (GETMENUPROP menu 'change-form] (if item then (SHADEITEM item menu BLACKSHADE) (APPLY* change-form self (if (LISTP item) then (CADR item) else item)) (for item in (fetch ITEMS of menu) do (if (APPLY* test-form self (if (LISTP item) then (CADR item) else item)) then (SHADEITEM item menu HIGHLIGHTSHADE) else (SHADEITEM item menu WHITESHADE] (PUTMENUPROP menu 'self self) (PUTMENUPROP menu 'test-form test-form) (PUTMENUPROP menu 'change-form change-form) (for item in (fetch ITEMS of menu) do (if (APPLY* test-form self (if (LISTP item) then (CADR item) else item)) then (SHADEITEM item menu HIGHLIGHTSHADE) else (SHADEITEM item menu WHITESHADE))) menu) (Method ((LatticeBrowser MessageFormForProcess) self obj selector args) (* ; "smL 17-Sep-86 17:48") "Create a form to evaluate in a new process that will send the obj the selector message with the given args" `(_ ,obj ,selector ., [for x in args collect (COND ((OR (NULL x) (Object? x)) x) (T (KWOTE x])) (Method ((LatticeBrowser MiddleSelection) self) (* ; "smL 15-May-85 19:04") "This function called from the GRAPHER package when a node is selected with the middle mouse button. If no node is selected then just returns." [PROG (objName selection object (window (@ window)) (latticeBrowser self)) (DECLARE (SPECVARS object latticeBrowser)) (COND ((NULL (SETQ object (FindSelectedNode window))) (RETURN))) (SETQ objName (GetObjectName object)) (_@ latticeBrowser lastSelectedObject object) (GETMOUSESTATE) (_ self FlipNode object) (COND ((MetaDown?) (* Invoke editor if Left Shift Key is  down) (_ self FlipNode object) (_ latticeBrowser MiddleShiftSelect object objName)) (T (_ self FlipNode object) (SETQ selection (OR (_ self MiddleChoice) (RETURN NIL))) (_ latticeBrowser DoSelectedCommand selection object objName)]) (Method ((LatticeBrowser MiddleShiftSelect) self object objname) (* ; "smL 17-Sep-86 18:31") "Called when item is selected with middle key and LSHIFT is down SendInTtyProcess is so this is done in the TTY process" (_ self DoCommandInProcess self 'EditObject (LIST object))) (Method ((LatticeBrowser NewItem) self newItem) (* ; "smL 23-Jan-85 13:02") "Return Object. Prompt for it if needed." ($! (OR newItem (_ self PromptRead "Give name of item to be added")))) (Method ((LatticeBrowser NodeRegion) self object) (* ; "smL 10-Dec-84 18:26") "what region does the object occupy in the display stream?" [LET [(node (FASSOC (COND ((LITATOM object) (SETQ object (GetObjectRec object))) (T object)) (fetch GRAPHNODES of (WINDOWPROP (@ window) 'GRAPH] (if node then (create REGION LEFT _ (IDIFFERENCE (fetch XCOORD of (fetch NODEPOSITION of node)) (IQUOTIENT (fetch NODEWIDTH of node) 2)) BOTTOM _ (IDIFFERENCE (fetch YCOORD of (fetch NODEPOSITION of node)) (IQUOTIENT (fetch NODEHEIGHT of node) 2)) WIDTH _ (fetch NODEWIDTH of node) HEIGHT _ (fetch NODEHEIGHT of node]) (Method ((LatticeBrowser ObjNamePair) self objOrName) (* ; "smL 15-Aug-86 09:24") "Make a pair (object . objName) where objName is label to be used in browser" [LET [(obj (if (Object? objOrName) then objOrName else (GetObjectRec objOrName] (if (NULL obj) then NIL elseif (_ obj InstOf! 'DestroyedObject) then NIL elseif [AND (@ goodList) (NOT (FMEMB obj (@ goodList)] then NIL elseif (FMEMB obj (@ badList)) then NIL else (CONS obj (_ self GetDisplayLabel objOrName)]) (Method ((LatticeBrowser ObjectFromLabel) self label) (* ; "smL 4-Jan-85 18:20") "What object has this label?" (LET [(objectNode (for node in (fetch GRAPHNODES of (WINDOWPROP (@ window) 'GRAPH)) thereis (EQUAL label (fetch NODELABEL of node] (if (NLISTP (CAR objectNode)) then (CAR objectNode) else NIL))) (Method ((LatticeBrowser PositionNode) self object windowX windowY) (* ; "smL 10-Dec-84 18:24") "scrolls the window so that the node is in the given position of the window. If windowX or windowY is a FLOATP, it it taken to be a window-relative postion; if a FIXP, it is a window-absolute position." (LET ((region (_ self NodeRegion object))) (if region then (_ self ScrollWindow (fetch LEFT of region) (fetch BOTTOM of region) windowX windowY)))) (Method ((LatticeBrowser Recompute) self dontReshapeFlg) (* ; "smL 8-Apr-87 14:42") "Recompute the browseGraph in the same window" (for obj in (@ startingList) when (OR (_ obj InstOf! 'DestroyedObject) (_ obj InstOf! 'DestroyedClass)) do (change (@ startingList) (REMOVE obj DATUM))) [PROG ((graphFits (_ self GraphFits T))) (_ self Show (@ startingList)) (COND ((OR dontReshapeFlg graphFits) (* Dont Reshape or rescroll.  Assume window wants to stay the same  size) ) (T (_ self ShapeToHold)] self) (Method ((LatticeBrowser RecomputeInPlace) self) (* ; "smL 10-Dec-84 18:27") "recompute the graph, maintaining the current position" (LET* ((visibleRegion (DSPCLIPPINGREGION NIL (@ window))) (x (fetch LEFT of visibleRegion)) (y (fetch BOTTOM of visibleRegion))) (* if we want to RecomputeInPlace, we must want the window to be kept the same) (_ self Recompute T) (* we had to save x and y because  visibleRegion gets clobbered by  Recompute! Suprise!) (_ self ScrollWindow x y))) (Method ((LatticeBrowser RecomputeLabels) self) (* ; "smL 27-Feb-85 11:27") "recompute the graph, including the labels" (_ self ClearLabelCache T) (_ self Recompute)) (Method ((LatticeBrowser RemoveFromBadList) self) (* ; "smL 28-Dec-85 10:04") "Remove an item from BadList to allow it to be displayed once again" [COND ((NULL (@ badList)) (CLRPROMPT) (PROMPTPRINT "No BadList items.")) (T (PROG [(item (MENU (create MENU TITLE _ "BadList Items" ITEMS _ (@ badList)] (COND (item (_@ badList (DREMOVE item (@ badList))) (_ self Recompute)) (T (CLRPROMPT) (PROMPTPRINT "Nothing Selected"]) (Method ((LatticeBrowser RemoveHighlights) self) (* ; "smL 13-Dec-85 15:16") "gets rid of all highlighting in the lattice" (for node in (fetch GRAPHNODES of (WINDOWPROP (@ window) 'GRAPH)) do (_ self DisplayNodeHightlights node NIL)) (change (@ boxedNode) NIL)) (Method ((LatticeBrowser RemoveShading) self) (* ; "smL 13-Dec-85 15:14") "gets rid of all shading in the lattice" (for node in (fetch GRAPHNODES of (WINDOWPROP (@ window) 'GRAPH)) do (_ self DisplayNodeShading node WHITESHADE))) (Method ((LatticeBrowser SaveInIT) self) (* ; "smL 5-Sep-86 12:40") "A Browser command to save self in SavedValue" (PutSavedValue self)) (Method ((LatticeBrowser ShadeNode) self object shade) (* ; "smL 15-Jan-87 18:34") "shade the background of a node" (LET [(node (FASSOC (COND ((LITATOM object) (SETQ object (GetObjectRec object))) (T object)) (fetch GRAPHNODES of (WINDOWPROP (@ window) 'GRAPH] (if node then [if (BITMAPP (fetch NODELABEL of node)) then (* Need to forget the old bitmap, in case it already has a shade blt'ed into it.  This will fail if the GetDisplayLabel msg returns something different from the  previous value, but what can you do?) (_ self ClearLabelCache object) (LET ((newLabel (_ self GetDisplayLabel object))) (replace NODELABEL of node with newLabel) (if (AND shade (BITMAPP newLabel)) then (BITBLT NIL NIL NIL newLabel NIL NIL NIL NIL 'TEXTURE 'PAINT shade] (_ self DisplayNodeShading node shade)))) (Method ((LatticeBrowser ShapeToHold) self) (* ; "smL 13-Jan-87 16:52") "Shape the browse window to just hold the nodes with BrowserMargin to spare" (PROG [left bottom height width right top [minWidth (IPLUS 5 (STRINGWIDTH (@ title) (DSPFONT NIL WindowTitleDisplayStream ] [minHeight (FONTHEIGHT (DSPFONT NIL (@ window)] (region (WINDOWPROP (@ window) 'REGION)) (nodes (fetch GRAPHNODES of (WINDOWPROP (@ window) 'GRAPH] [OR nodes (RETURN (_ self SetRegion (CREATEREGION (fetch LEFT of region) (fetch BOTTOM of region) minWidth minHeight))] (SETQ left (MIN/LEFT nodes)) (SETQ bottom (MIN/BOTTOM nodes)) (SETQ right (MAX/RIGHT nodes)) (SETQ top (MAX/TOP nodes)) [SETQ width (IMAX minWidth (IMIN MaxLatticeWidth (WIDTHIFWINDOW (PLUS BrowserMargin (IDIFFERENCE right left)) (WINDOWPROP (@ window) 'BORDER] [SETQ height (IMAX minHeight (IMIN MaxLatticeHeight (PLUS BrowserMargin (IDIFFERENCE top bottom] (AND (EQP width (fetch WIDTH of region)) (EQP (HEIGHTIFWINDOW height (WINDOWPROP (@ window) 'TITLE) (WINDOWPROP (@ window) 'BORDER)) (fetch HEIGHT of region)) (RETURN T)) (_ self SetRegion (CREATEREGION (fetch LEFT of region) (fetch BOTTOM of region) width height)))) (Method ((LatticeBrowser Show) self browseList windowOrTitle goodList) (* ; "smL 13-Dec-85 14:04") "Show the items and their subs on a browse window." (* ;;; "If windowOrTitle is not a window it will be used as a title for a window which will be created.") (COND ((WINDOWP windowOrTitle) (_@ window windowOrTitle)) (windowOrTitle (_@ title windowOrTitle))) [COND ((AND browseList (NLISTP browseList)) (SETQ browseList (LIST browseList] (_@ startingList (for C in browseList when (GetObjectRec C) collect (GetObjectRec C))) [AND goodList (_@ goodList (for C in goodList when (GetObjectRec C) collect (GetObjectRec C)))] (_ self DisplayBrowser)) (Method ((LatticeBrowser Shrink) self towhat iconPos expandFn) (* ; "smL 1-Jul-85 18:15") "the default icon should be used if there is no explicit icon given" (DECLARE (GLOBALVARS BrowserIconBM)) (LET ((window (@ window))) (WINDOWADDPROP window 'EXPANDFN 'LatticeBrowserExpandFn) [if [AND (NULL towhat) (NULL (WINDOWPROP window 'ICON)) (NULL (WINDOWPROP window 'ICONWINDOW] then (SETQ towhat (LET ((dsp (DSPCREATE (BITMAPCOPY BrowserIconBM))) (iconFont (FONTCREATE 'GACHA 8)) (title (_ self IconTitle))) (DSPFONT iconFont dsp) (DSPOPERATION 'INVERT dsp) (if (IGREATERP (STRINGWIDTH title iconFont) 75) then (DSPXPOSITION 2 dsp) (DSPYPOSITION 33 dsp) (PRIN1 title dsp) else (CENTERPRINTINREGION title (CONSTANT (CREATEREGION 0 31 77 10)) dsp)) (DSPDESTINATION NIL dsp))) (SETQ iconPos (OR iconPos (GETBOXPOSITION (BITMAPWIDTH towhat) (BITMAPHEIGHT towhat] (LET ((icon (_Super self Shrink towhat iconPos expandFn))) (WINDOWPROP icon 'BUTTONEVENTFN (FUNCTION LatticeBrowserIconButtonEventFn)) icon))) (Method ((LatticeBrowser SubBrowser) self obj objName) (* ; "dgb: 13-Sep-84 22:10") "Create a subbrowser on selected object" (_New (Class self) Browse obj)) (Method ((LatticeBrowser TitleSelection) self) (* ; "smL 17-Sep-86 18:33") "Do TitleItems if selected in title area. Replaces TitleSelection in Window because this one does evaluation in TTY process, and saves events on history" (LET* [(menu (_ self ChoiceMenu 'TitleItems)) (choice (AND menu (MENU menu] (if choice then (_ self DoCommandInProcess self choice NIL)))) (Method ((LatticeBrowser UnmarkNodes) self) (* ; "smL 10-Dec-84 12:27") "clear the graph nodes, removing all shading and highlighting" (_ self RemoveHighlights) (_ self RemoveShading)) (Method ((LatticeBrowser Unread) self object objName) (* ; "smL 15-Aug-86 10:57") "Unread name into system buffer - or if no node, unread the entire graph" (LET [(imageObj (COND (object objName) (T (GRAPHEROBJ (LET [(graph (WINDOWPROP (@ window) 'GRAPH] (* ;; "Need to make a copy of the graph w/o any objects, so non-Loops systems can look at the resulting graph") (create GRAPH using graph GRAPHNODES _ (for node in (fetch GRAPHNODES of graph) collect (create GRAPHNODE using node NODEID _ (\PortableGraphNodeID (fetch NODEID of node)) TONODES _ (for id in (fetch TONODES of node) collect (  \PortableGraphNodeID id)) FROMNODES _ (for id in (fetch FROMNODES of node) collect (  \PortableGraphNodeID id] (* ;  "Need to check for TEdit target, since TEdit doesn't use the COPYINSERT protocol!") (if (AND (NOT (OR (STRINGP imageObj) (IMAGEOBJP imageObj))) (WINDOWPROP (PROCESS.TTY (TTY.PROCESS)) 'COPYINSERTFN)) then (* ;; "It is expecting something and we don't have an image object or string to give it, so we need to convert it first") (COPYINSERT (MKSTRING imageObj)) else (COPYINSERT imageObj)))) (Method ((LatticeBrowser Update) self) "Make sure the graph gets updated too" (_Super ) (REDISPLAYW (@ window))) (Method ((MetaBrowser CareAbout?) self object) "We care if object is a class which is a subclass of Class; yes, this is a hack" [COND ((AND (\Loading-File?) (FMEMB self ClassBrowsersThatNeedUpdating)) (* ;; "This browser is going to get updated already, so it doesn't care") NIL) ((OR (FMEMB object (@ goodList)) (_Try object Subclass ($ Class]) (Method ((SupersBrowser CareAbout?) self object) "We care if object is a class, is not on our badList, and is a superclass of something on our startingList" [COND ((AND (\Loading-File?) (FMEMB self ClassBrowsersThatNeedUpdating)) (* ;; "This browser is going to get updated already, so it doesn't care") NIL) ((OR (NOT (Class? object)) (FMEMB object (@ badList))) NIL) ((OR (FMEMB object (@ goodList)) (for c in (@ startingList) thereis (_Try c Subclass object]) (\UnbatchMethodDefs) (DEFINEQ (AddMenuWindow (LAMBDA (menu-group main-window edge menu-window-title) (* smL "10-Sep-86 16:11") (* * Add an attached window to self containing the given menus - put the menus in a row unless vertical? is true, in which case stack them in a single column) (LET* ((minimum-menu-size (Menu-Group-Size menu-group)) (minimum-window-size (CONS (WIDTHIFWINDOW (CAR minimum-menu-size)) (HEIGHTIFWINDOW (CDR minimum-menu-size) menu-window-title))) (menu-window (CREATEW (CREATEREGION 0 0 (CAR minimum-window-size) (CDR minimum-window-size)) menu-window-title NIL T))) (WINDOWPROP menu-window 'MINSIZE minimum-window-size) (WINDOWPROP menu-window 'MAXSIZE (SELECTQ edge ((TOP BOTTOM) (CONS NIL (HEIGHTIFWINDOW (CDR minimum-menu-size) menu-window-title))) ((LEFT RIGHT) (CONS (WIDTHIFWINDOW (CAR minimum-menu-size)) NIL)) NIL)) (WINDOWPROP menu-window 'menu-group menu-group) (WINDOWADDPROP menu-window 'REPAINTFN 'Repaint-Menu-Window) (WINDOWADDPROP menu-window 'RESHAPEFN (FUNCTION (LAMBDA (window) (REDISPLAYW window)))) (ATTACHWINDOW menu-window main-window edge 'JUSTIFY 'LOCALCLOSE) menu-window))) (BoxPrintString [LAMBDA (string maxCharsWidth maxLines font oldBitmap) (* ; "Edited 13-Aug-90 15:23 by jds") (* ;;; "return a bitmap containing the string, in the given font, with maxWidth at most width") (* ;  "max sizes of NULL or 0 mean no max size") (SETQ maxCharsWidth (OR maxCharsWidth 0)) (SETQ maxLines (OR maxLines 0)) (if (ZEROP maxCharsWidth) then (* ;  "if no max width, then just return the string") string else (PROG ((maxWidth (ITIMES maxCharsWidth (STRINGWIDTH "A" font))) (nchars (NCHARS string)) (nlines 0) (spos 0) (region (create REGION)) (trueMaxWidth 0) nextpos dsp substr) (* ;; "The region above used to be a constant to save conses; this is a processworld error, and screwed up the PavCompiler to boot.") (SETQ string (MKSTRING string)) (* ;  "first we need to find the size of the resultant bitmap") NEXTBREAK (if (ILESSP spos nchars) then (add nlines 1) (* ;  "always at least one character, even if exceed maxWidth") [SETQ nextpos (IMAX 1 (CAR (BreakStringForBoxing (SUBSTRING string (ADD1 spos) -1) maxWidth font] (SETQ trueMaxWidth (IMAX trueMaxWidth (STRINGWIDTH (SUBSTRING string (ADD1 spos) (IPLUS spos nextpos)) font))) (add spos nextpos) (GO NEXTBREAK)) (if (NOT (ZEROP maxLines)) then (SETQ nlines (IMIN maxLines nlines))) (* ;  "now that we have the size, lets build it") [SETQ dsp (DSPCREATE (if [AND oldBitmap (NOT (OR (GREATERP trueMaxWidth (BITMAPWIDTH oldBitmap) ) (GREATERP (ITIMES nlines (FONTPROP font 'HEIGHT)) (BITMAPHEIGHT oldBitmap] then oldBitmap else (SETQ oldBitmap (BITMAPCREATE trueMaxWidth (ITIMES nlines (FONTPROP font 'HEIGHT] (DSPFONT font dsp) (* ;; "Will Snow says to reset dsp manually instead of doing (DSPRESET dsp), at least until DSPRESET becomes less bogus...") (replace (REGION LEFT) of region with 0) (replace (REGION WIDTH) of region with trueMaxWidth) (replace (REGION HEIGHT) of region with (BITMAPHEIGHT oldBitmap)) (replace (REGION BOTTOM) of region with 0) (DSPCLIPPINGREGION region dsp) (DSPFILL NIL NIL NIL dsp) (DSPXPOSITION 0 dsp) (DSPYPOSITION (IDIFFERENCE (BITMAPHEIGHT oldBitmap) (FONTPROP font 'HEIGHT)) dsp) (* ;; "Replace the stuff between the comments with (DSPRESET dsp) someday.") (SETQ spos 0) (replace (REGION LEFT) of region with 0) (replace (REGION WIDTH) of region with trueMaxWidth) (replace (REGION HEIGHT) of region with (FONTPROP font 'HEIGHT)) [replace (REGION BOTTOM) of region with (ITIMES nlines (FONTPROP font 'HEIGHT] NEXTPIECE (add nlines -1) (if (ILESSP spos nchars) then [SETQ nextpos (IMAX 1 (CAR (BreakStringForBoxing (SUBSTRING string (ADD1 spos) -1) trueMaxWidth font] (SETQ substr (SUBSTRING string (ADD1 spos) (IPLUS nextpos spos))) (replace (REGION BOTTOM) of region with (IDIFFERENCE (fetch (REGION BOTTOM) of region) (fetch (REGION HEIGHT) of region))) (if (AND (ZEROP nlines) (ILESSP (IPLUS nextpos spos) nchars)) then (* ; "opps, we need to abbreviate!") (CENTERPRINTINREGION (CONCAT (if (IGREATERP (CL:LENGTH substr) 3) then (SUBSTRING substr 1 -3) else substr) "...") region dsp) (GO ALLDONE) else (* ; "print out this piece") (CENTERPRINTINREGION substr region dsp) (add spos nextpos) (GO NEXTPIECE))) ALLDONE (RETURN (DSPDESTINATION NIL dsp]) (BoxWindowNode (LAMBDA (nodeLabel window) (* dgb%: " 7-Sep-84 14:36") (* Puts a box around the node with nodeLabel in the graph. A nodeLabel in browsers is an object. Does nothing if node not found.) (PROG (node nodes) (COND ((AND (WINDOWP window) (SETQ nodes (fetch GRAPHNODES of (WINDOWPROP window 'GRAPH))) (SETQ node (FASSOC nodeLabel nodes))) (DRAWAREABOX (GN/LEFT node) (GN/BOTTOM node) (fetch NODEWIDTH of node) (fetch NODEHEIGHT of node) 1 'INVERT window)))))) (BreakStringForBoxing (LAMBDA (MSG WIDTH FONT) (* ; "Edited 5-Jun-87 19:51 by smL") (* ;;; "Stolen from the function ICONW.FORMATLINE -- modified to try to break at 'word' boundaries, whatever they are") (* ;; "Returns a list of the char# relative to char 1 of where to break next line, and how much space was left over (for centering &c)") (COND (MSG (* ; "If there really is a title, go ahead and format the next line.") (bind (TX _ 0) (LASTB _ 0) (CH _ 0) (TMSG _ (OPENSTRINGSTREAM MSG)) (MSGLEN _ (NCHARS MSG)) for I from 1 by 1 do (* ; "Run thru the characters one by one.") (COND ((IGREATERP TX WIDTH) (* ; "We're past the right margin. Time to stop.") (CLOSEF? TMSG) (RETURN (COND ((LISTP LASTB) (* ; "There is a space we can break the line at. Break there.") LASTB) (T (* ; "There were no spaces on this line. Break after the last character that did fit.") (CONS (IDIFFERENCE I 2) (IDIFFERENCE WIDTH (IDIFFERENCE TX (CHARWIDTH CH FONT)))))) )) ((EOFP TMSG) (* ; "That was the last character.") (CLOSEF? TMSG) (RETURN (CONS (SUB1 I) (IDIFFERENCE WIDTH TX)))) (T (* ; "Look at the next character.") (SETQ CH (BIN TMSG)) (SELCHARQ CH ((SPACE %. %: ; %, / \ * - %#) (* ; "Remember where word breaks are, so we can back up and split lines there if possible.") (SETQ LASTB (CONS I (IDIFFERENCE WIDTH TX)))) (CR (* ; "CR forces a new line.") (RETURN (CONS (IMINUS I) (IDIFFERENCE WIDTH TX)))) (if (AND (NOT (U-CASEP (CHARACTER CH))) (NOT (EOFP TMSG)) (U-CASEP (PEEKC TMSG))) then (* ; "changing from upper to lower case is also a word break") (SETQ LASTB (CONS I (IDIFFERENCE WIDTH TX))))) (SETQ TX (IPLUS TX (CHARWIDTH CH FONT))))))) (T (* ; "There isn't a title; return a dummy entry for the line formatter.") (CONS 0 WIDTH))))) (Browse (LAMBDA (classes title goodClasses position) (* dgb%: "15-Oct-84 10:06") (* Build a browser, shape it, and make it movable) (_New ($ ClassBrowser) Browse classes title (COND ((EQ goodClasses T) classes) (T goodClasses)) position))) (ClearCache (LAMBDA NIL (* smL "13-Jan-87 16:47") (LET ((window (first (CLRPROMPT) (printout PROMPTWINDOW "Move mouse to desired window." T "Then press down the CTRL key or click mouse") until (OR (KEYDOWNP 'CTRL) (NOT (MOUSESTATE UP))) do NIL finally (GETMOUSESTATE) (CLRPROMPT) (RETURN (WHICHW))))) (AND window (SETQ window (WINDOWPROP window 'LoopsWindow)) (_ window ClearMenuCache))))) (DoMenuMethod (LAMBDA (object items) (* edited%: "13-NOV-83 16:20") (PROG ((selector (AND items (DualMenu items)))) (AND selector (RETURN (_! object selector)))))) (DualMenu (LAMBDA (items whenHeldFn) (* dgb%: " 9-FEB-84 16:17") (* creates and pops up a menu which allows differential selection on left an middle buttons) (MENU (create MENU ITEMS _ items WHENSELECTEDFN _ 'SubItemSelection SUBITEMFN _ 'DualSubItems WHENHELDFN _ whenHeldFn CHANGEOFFSETFLG _ T)))) (DualSelection (LAMBDA (item menu button) (* dgb%: "29-MAR-83 17:57") (* A menu WHENSELECTEDFN which allows differential selection on left and middle button. For such differential selection item should be of form - (itemSeenInMenu (leftValue midValue)) - where midValue can be an atom which is directly returned when item is selected with middle, or midValue can be an itemList, which will be displayed in a subselection menu) (PROG (it it1) (RETURN (COND ((NLISTP item) item) ((NLISTP (SETQ it (CADR item))) it) ((EQ (SETQ it1 (CAR it)) 'QUOTE) (CADR it)) ((EQ it1 'PROGN) (EVAL it)) ((EQ button 'LEFT) (COND ((LISTP it1) (EVAL it1)) (T it1))) ((NLISTP (SETQ it1 (CADR it))) it1) (T (DualMenu it1))))))) (DualSubItems [LAMBDA (menu item) (* ; "Edited 21-Jun-88 17:30 by TAL") (* ;; "A menu WHENSELECTEDFN which allows differential selection on left and middle button. For such differential selection item should be of form --- (itemSeenInMenu (leftValue midValue)) --- where midValue can be an atom which is directly returned when item is selected with middle, or midValue can be an itemList, which will be displayed in a subselection menu") (* ;  "Made this recognize standard subitem format also -- TAL") (PROG (it it1) (RETURN (COND [[OR (NLISTP item) (NLISTP (SETQ it (CADR item))) (EQ (SETQ it1 (CAR it)) 'QUOTE) (EQ it1 'PROGN) (NLISTP (SETQ it1 (CADR it] (COND ((AND (LISTP item) (LISTP (SETQ it (CADDDR item))) (EQ (CAR it) 'SUBITEMS)) (CDR it] (T it1]) (FILECLASSES (LAMBDA (FILE) (* dgb%: "13-DEC-83 09:32") (FILECOMSLST FILE 'CLASSES))) (FileBrowse (LAMBDA (fileName) (* dgb%: " 7-Sep-84 17:06") (_New ($ FileBrowser) BrowseFile fileName))) (FindSelectedNode (LAMBDA (WINDOW) (* smL "10-Dec-84 17:53") (* Used in BUTTONEVENTFN and gets called whenever cursor moves or button is down. Adapted from APPLYTOSELECTEDNODE in GRAPHER package; returns the selected item rather than applying a function on the inside of the button event fn.) (PROG ((loopsWindow (WINDOWPROP WINDOW 'LoopsWindow)) (NODELST (fetch (GRAPH GRAPHNODES) of (WINDOWPROP WINDOW 'GRAPH))) (DS (WINDOWPROP WINDOW 'DSP)) BUTTON OLDPOS REG NOW NEAR) (* note which button is down.) (* get the region of this window.) (SETQ REG (WINDOWPROP WINDOW 'REGION)) (until (LASTMOUSESTATE (OR LEFT MIDDLE)) do (GETMOUSESTATE)) (SETQ NEAR (NODELST/AS/MENU NODELST (SETQ OLDPOS (CURSORPOSITION NIL DS)))) FLIP (AND NOW (FLIPNODE NOW DS)) (AND NEAR (FLIPNODE NEAR DS)) (SETQ NOW NEAR) LP (* wait for a button up or move out of region) (GETMOUSESTATE) (COND ((NOT (LASTMOUSESTATE (OR LEFT MIDDLE))) (* button up, process it.) (AND NOW (FLIPNODE NOW DS)) (* NOW node has been selected.) (RETURN (fetch NODEID of NOW))) ((NOT (INSIDE? (WINDOWPROP WINDOW 'REGION) LASTMOUSEX LASTMOUSEY)) (* outside of region, return) (AND NOW (FLIPNODE NOW DS)) (RETURN)) ((EQ NOW (SETQ NEAR (NODELST/AS/MENU NODELST (CURSORPOSITION NIL DS OLDPOS)))) (GO LP)) (T (GO FLIP)))))) (FunctionMenuWhenSelectedFn (LAMBDA (choice menu key) (* ; "Edited 2-Jun-87 18:48 by smL") (COND ((EQ choice '*NewFunction*) (AND (SETQ choice (PromptRead "Please tell me the name of the new function")) (DEFINE `((,choice NIL (* Comment) NIL))) (ADDTOFILE choice 'FNS (WINDOWPROP (WFROMMENU menu) 'file))))) (AND choice (APPLY* 'DF choice)))) (ItemsForType (LAMBDA (browser object objName type) (* smL "11-Apr-86 14:54") (COND ((NULL (@ browser boxedNode)) (_ browser PromptPrint "First Box the node which is target for move.") NIL) (T (LET ((items (SORT (_ object ListAttribute type)))) (COND ((NULL items) (_ browser PromptPrint (CONCAT objName " has no " type)) NIL) (T items))))))) (LatticeBrowser.ButtonFn (LAMBDA (window) (* smL " 7-Apr-86 11:11") (* * Invoked when a mouse button is depressed in the LatticeBrowser window.) (COND ((KEYDOWNP 'CTRL) (RESETLST (RESETSAVE (DSPOPERATION 'INVERT window) (LIST (FUNCTION DSPOPERATION) (DSPOPERATION NIL window) window)) (GETMOUSESTATE) (EDITMOVENODE window))) ((NULL (INSIDEP (DSPCLIPPINGREGION NIL window) (LASTMOUSEX window) (LASTMOUSEY window))) (* In the title region) (_ (WINDOWPROP window 'LatticeBrowser) TitleSelection)) (T (APPLYTOSELECTEDNODE window))))) (LatticeBrowser.WhenHeldFn (LAMBDA (item menu key) (* ; "Edited 25-Jun-87 14:17 by smL") (* ;;; "Prints documentation for the method, either from the item list of from the class of object or latticeBrowser, bound above") (DECLARE (SPECVARS object latticeBrowser)) (RESETVAR PROMPTWINDOW (_ latticeBrowser GetPromptWindow) (PROMPTPRINT (COND ((LITATOM item) (* ; "Get method documentation from object or browser") (COND ((_ object Understands item) (GetMethod (Class object) item 'doc)) (T (GetMethod (Class latticeBrowser) item 'doc)))) ((AND (LISTP item) (CDDR item)) (CADDR item)) (T "When released this item will be selected")))))) (LatticeBrowserExpandFn [LAMBDA (window) (* ; "Edited 14-Jun-88 12:54 by TAL") (* ;; "When a browser window is expanded, it should be recomputed") (LET [(self (WINDOWPROP window 'LoopsWindow] (AND UpdateClassBrowsers? (_ self RecomputeInPlace)]) (LatticeBrowserIconButtonEventFn (LAMBDA (iconWindow) (* smL "29-May-85 14:49") (if (MetaDown?) then (LET ((windowForMenu (WINDOWPROP (WINDOWPROP iconWindow 'ICONFOR) 'LoopsWindow))) (_ windowForMenu TitleSelection)) elseif (MOUSESTATE LEFT) then (MOVEW iconWindow) elseif (MOUSESTATE MIDDLE) then (EXPANDW iconWindow)))) (LispxSend (NLAMBDA (MSGFORM) (* edited%: " 3-Apr-86 17:23") (* Send a message given, recording on history, protected form errors I can't remember why we put in the RELSTK) (PROG ((\INSIDE.TTYIN)) (DECLARE (SPECVARS MSGFORM)) (ERSETQ (LISPXEVAL MSGFORM)) (AND (RELSTK (STKPOS 'DEDITL)) (ERROR!))))) (Menu-Group-Size (LAMBDA (menu-group) (* smL "10-Sep-86 09:53") (* * Compute the minimum size of the menu group) (\Menu-Group-Size menu-group NIL))) (Repaint-Menu-Window (LAMBDA (window) (* smL "10-Sep-86 10:57") (* * Repaint the menus in the window) (LET ((menu-group (WINDOWPROP window 'menu-group))) (\Remove-Menu-Group-From-Window menu-group window) (CLEARW window) (\Place-Menu-Group-In-Window menu-group (Menu-Group-Size menu-group) window 0 0 (WINDOWPROP window 'WIDTH) (WINDOWPROP window 'HEIGHT) NIL)))) (SubItemSelection (LAMBDA (item menu button) (* dgb%: "13-DEC-83 21:03") (* A menu WHENSELECTEDFN which allows differential selection on left and middle button. For such differential selection item should be of form - (itemSeenInMenu (leftValue midValue)) - where midValue can be an atom which is directly returned when item is selected with middle, or midValue can be an itemList, which will be displayed in a subselection menu) (PROG (it it1) (RETURN (COND ((NLISTP item) item) ((NLISTP (SETQ it (CADR item))) it) ((EQ (SETQ it1 (CAR it)) 'QUOTE) (CADR it)) ((EQ it1 'PROGN) (EVAL it)) ((LISTP it1) (EVAL it1)) (T it1)))))) (TreeRoots (LAMBDA (nodeLst) (* smL "29-Sep-86 19:46") (* * Computes a minimal set of root nodes for a lattice - those with no connections TO them in list of nodes, or a single node from a cycle of nodes.) (PROG ((rootNodes (LDIFFERENCE nodeLst (for node in nodeLst join (ChildNodes node nodeLst)))) reachableNodes notReachableNodes) (SETQ reachableNodes (COPY rootNodes)) (SETQ notReachableNodes (LDIFFERENCE nodeLst reachableNodes)) (* * recompute the nodes that can't be reached from the current rootNodes) RecomputeReachableNodes (* * Compute the transitive closure of the set of reachableNodes - updating the notReachableNodes at the same time) (for node in reachableNodes do (for childNode in (ChildNodes node nodeLst) when (MEMB childNode notReachableNodes) do (* TRICK%: put the newly found reachable node at the end of the list, so we will find it later on during this iteration) (NCONC1 reachableNodes childNode) (SETQ notReachableNodes (DREMOVE childNode notReachableNodes)))) (* * if we can reach all the nodes, fine...) (if (NULL notReachableNodes) then (* * Now need to prune down to a minimal set) (bind (stable? _ NIL) until stable? do (SETQ stable? T) (for node in rootNodes bind extraRoots do (SETQ extraRoots (DREMOVE node (INTERSECTION rootNodes (ReachableNodes! node nodeLst))) ) (if extraRoots then (SETQ stable? NIL) (SETQ rootNodes (LDIFFERENCE rootNodes extraRoots)) (RETURN T)) finally (RETURN NIL))) (* should return the node ids, not the GRAPHNODES) (RETURN (for node in rootNodes collect (fetch NODEID of node))) else (* There must be a cycle. Select the least prolific node in the cycle as the a new root node.) (push rootNodes (LET ((prolificNode (for node in notReachableNodes smallest (LENGTH (fetch TONODES of node))))) (SETQ notReachableNodes (DREMOVE prolificNode notReachableNodes )) prolificNode)) (GO RecomputeReachableNodes))))) (ReachableNodes! (LAMBDA (root nodeList) (* smL "30-Sep-86 10:22") (* * Return a list of all nodes that are reachable from the root) (LET ((reachableNodes (LIST root))) (for node in reachableNodes do (for childNode in (ChildNodes node nodeList) when (NOT (MEMB childNode reachableNodes)) do (* TRICK%: put the newly found reachable node at the end of the list, so we will find it later on during this iteration) (NCONC1 reachableNodes childNode))) reachableNodes))) (ChildNodes (LAMBDA (parentNode nodeList) (* markM " 8-Oct-85 14:15") (* * Find all GRAPHNODES that are immediatly reachable from this node) (for label in (fetch TONODES of parentNode) collect (for node in nodeList thereis (EQ label (fetch NODEID of node)))))) (\DeleteSubtree (LAMBDA (self graph obj) (* smL " 5-Jun-86 14:15") (* * Delte the object and any of its subchildren from the graph) (for child in (fetch TONODES of (for node in (fetch GRAPHNODES of graph) thereis (EQ obj (CAR node)))) when (NOT (MEMB child (@ badList))) do (pushnew (@ badList) child) (\DeleteSubtree self graph child)))) (\Menu-Group-Size [LAMBDA (menu-group vertical?) (* ; "Edited 13-Aug-90 15:24 by jds") (* * Compute the minimum size of the menu group) (if (type? MENU menu-group) then (CONS (PLUS 2 (fetch (MENU IMAGEWIDTH) of menu-group)) (PLUS 2 (fetch (MENU IMAGEHEIGHT) of menu-group))) elseif (STRINGP menu-group) then [CONS (PLUS 2 (STRINGWIDTH menu-group (DSPFONT NIL WindowTitleDisplayStream))) (PLUS 2 (FONTPROP (DSPFONT NIL WindowTitleDisplayStream) 'HEIGHT] elseif vertical? then (for menu in menu-group bind (running-size _ (CONS 0 0)) size do (SETQ size (\Menu-Group-Size menu NIL)) (change (CAR running-size) (MAX DATUM (CAR size))) (add (CDR running-size) (CDR size)) finally (RETURN running-size)) else (for menu in menu-group bind (running-size _ (CONS 0 0)) size do (SETQ size (\Menu-Group-Size menu T)) (add (CAR running-size) (CAR size)) (change (CDR running-size) (MAX DATUM (CDR size))) finally (RETURN running-size]) (\Place-Menu-Group-In-Window [LAMBDA (menu-group menu-group-size window left bottom width height vertical?) (* ; "Edited 2-Aug-2022 10:17 by lmm") (* ; "Edited 25-Jun-87 14:17 by smL") (* ;;; "Place the menu-group in the region of the window given by the left, bottom, width, and height") (DECLARE (GLOBALVARS WindowTitleDisplayStream)) (LET [(excess-width (DIFFERENCE width (CAR menu-group-size))) (excess-height (DIFFERENCE height (CDR menu-group-size] (if (type? MENU menu-group) then [ADDMENU menu-group window (create POSITION XCOORD _ (PLUS left (QUOTIENT excess-width 2)) YCOORD _ (PLUS bottom (QUOTIENT excess-height 2] elseif (STRINGP menu-group) then (RESETLST [RESETSAVE NIL `(DSPFONT ,(DSPFONT (DSPFONT NIL WindowTitleDisplayStream) window) ,window] (CENTERPRINTINREGION menu-group (CREATEREGION left bottom width height) window)) elseif vertical? then (for menu in menu-group bind [spaces _ (QUOTIENT excess-height (ADD1 (LENGTH menu-group ] (running-bottom _ (PLUS bottom height)) menu-size do (SETQ menu-size (\Menu-Group-Size menu NIL)) [change running-bottom (DIFFERENCE DATUM (PLUS spaces (CDR menu-size] (\Place-Menu-Group-In-Window menu menu-size window left running-bottom width (CDR menu-size) NIL)) else (for menu in menu-group bind [spaces _ (QUOTIENT excess-width (ADD1 (LENGTH menu-group ] (running-left _ left) menu-size do (SETQ menu-size (\Menu-Group-Size menu T)) (add running-left space) (\Place-Menu-Group-In-Window menu menu-size window running-left bottom (CAR menu-size) height T) (add running-left (CAR menu-size]) (\PortableGraphNodeID (LAMBDA (id) (* smL "15-Aug-86 11:11") (* * Create a graph node id from the given id that can be ported to nonLoops systems) (if (NOT (Object? id)) then (PACK* id) elseif (GetObjectName id) then (PACK* (LIST '$ (OR (GetObjectName id) (UID id)))) else (PACK* (LIST '$& (_ id ClassName) (UID id)))))) (\Remove-Menu-Group-From-Window (LAMBDA (menu-group window) (* smL "10-Sep-86 17:26") (* * Remove the menu group from the window) (if (STRINGP menu-group) then NIL elseif (LISTP menu-group) then (for menu in menu-group do (\Remove-Menu-Group-From-Window menu window)) elseif (MEMB menu-group (WINDOWPROP window 'MENU)) then (DELETEMENU menu-group NIL window)))) ) (RPAQQ BrowserMargin 0) (RPAQQ GRAYSHADE1 1) (RPAQQ GRAYSHADE2 1025) (RPAQQ GRAYSHADE3 64510) (RPAQQ GRAYSHADE4 65534) (RPAQQ MaxLatticeHeight 750) (RPAQQ MaxLatticeWidth 900) (RPAQQ NestedMenuFlg T) (DECLARE%: DOEVAL@COMPILE DONTCOPY (SPECVARS MaxLatticeHeight MaxLatticeWidth) ) (RPAQQ BrowserIconBM #*(77 42)OOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOHO@@@@@@@@@@@@@@@@@GHN@@@@@@@@@@@COOO@@CHL@@@@@@@@@@@COOO@@AHL@@@@@@@@@@@GOOO@@AHL@@@@@@@@@@@KOOO@@AHL@@@@@@@@@@ACOOO@@AHL@@@@@@@@@@BCOOO@@AHL@@@@@@@@@@D@@@@@@AHL@@@@@@OOOLH@@@@@@AHL@@@@@@OOOM@@@@@@@AHL@@@@@AOOON@@@@@@@AHL@@@@@BOOON@@@@@@@AHL@@@@@DOOOM@@@@@@@AHL@@@@@HOOOLH@@@@@@AHL@@@@A@@@@@D@@@@@@AHLAOOOB@@@@@B@@@@@@AHLAOOOD@@@@@ACOOO@@AHLAOOOH@@@@@@KOOO@@AHLAOOOH@@@@@@GOOO@@AHLAOOOD@@@@@@COOO@@AHLAOOOB@@@@@@COOO@@AHL@@@@A@@@@@@COOO@@AHL@@@@@HOOOL@@@@@@@AHL@@@@@DOOOL@@@@@@@AHL@@@@@BOOOL@@@@@@@AHL@@@@@AOOOL@@@@@@@AHL@@@@@@OOOL@@@@@@@AHN@@@@@@OOOL@@@@@@@CHO@@@@@@@@@@@@@@@@@GHOOOOOOOOOOOOOOOOOOOHOOOOOOOOOOOOOOOOOOOH ) (* ;;; "Class browser") (\BatchMethodDefs) (METH ClassBrowser AddCategoryMenu NIL "Add a menu to the browser for specifying what method categories should be viewed" (category (ClassBrowser))) (METH ClassBrowser MessageFormForProcess (obj selector args) "Create a form to evaluate in a new process that will send the obj the selector message with the given args" (category (LatticeBrowser))) (METH ClassBrowser AddNewCV (object objName) "Add a new CV or edit an old one" (category (ClassBrowser))) (METH ClassBrowser AddNewIV (object objName) "Add a new IV or edit an old one" (category (ClassBrowser))) (METH ClassBrowser AddNewMethod (obj objName) "Calls class facility. Allows specialization of Adding Methods in subclasses Used to be called AddMethod" (category (ClassBrowser))) (METH ClassBrowser AddSpecializedMethod (obj objName file) "Specialize a method of the class" (category (ClassBrowser))) (METH ClassBrowser AddSuper (obj objName) "Add a super as first" (category (ClassBrowser))) (METH ClassBrowser BoxNode (object objName) "Box selected node and unbox previous" (category (LatticeBrowser))) (METH ClassBrowser CVDoc (class className) "Show menu of classVariables and give documentation for each" (category (ClassBrowser))) (METH ClassBrowser ClassDoc (object objname) "Print out class documentation if there is any" (category (ClassBrowser))) (METH ClassBrowser CopyCVTo (object objName) "Selected CV is moved to boxed node" (category (ClassBrowser))) (METH ClassBrowser CopyIVTo (object objName) "Copy the selected IV to the boxed node" (category (ClassBrowser))) (METH ClassBrowser CopyMethodTo (object objName) "Selected Method is copied to boxedNode" (category (ClassBrowser))) (METH ClassBrowser DefineSubclass (object objName) "Define a new subclass, giving it a name typed in by user" (category (ClassBrowser))) (METH ClassBrowser DeleteCVUsingBrowser (obj objName) "Delete selected CV" (category (ClassBrowser))) (METH ClassBrowser DeleteClass (obj objName) "Delete Class" (category (ClassBrowser))) (METH ClassBrowser DeleteClassItem (class className type) "Delete an item from a class, or the class itself" (category (ClassBrowser))) (METH ClassBrowser DeleteIVUsingBrowser (obj objName) "Delete selected IV" (category (ClassBrowser))) (METH ClassBrowser DeleteMethodUsingBrowser (obj objName) "Delete selected Method" (category (ClassBrowser))) (METH ClassBrowser DestroyAndRecompute (object objName) "Destroy class and recompute lattice." (category (ClassBrowser))) (METH ClassBrowser EditCategory (object objName) "Let the user select the category of the methods to edit" (category (ClassBrowser))) (METH ClassBrowser FindWhere (object objName type) "Ask user whether CVs IVs or Methods wanted and then find that one" (category (ClassBrowser))) (METH ClassBrowser GetMethodDoc (object objName) "Find the method requested and then ask the class" (category (ClassBrowser))) (METH ClassBrowser GetSubs (obj objName) "Returns subclasses of a class on goodlist If goodlist is NIL take everyone you come to who is not bad. any" (category (LatticeBrowser))) (METH ClassBrowser IVDoc (class className) "Show menu of classVariables and give documentation for each" (category (ClassBrowser))) (METH ClassBrowser LeftShiftSelect (object objname) (* Called when item is selected with left key and LSHIFT is down) (category (LatticeBrowser))) (METH ClassBrowser MethodMenu (object objName) "make a menu for editing this classes methods" (category (ClassBrowser))) (METH ClassBrowser MoveCVTo (object objName) "Move the selected CV to boxedNode" (category (ClassBrowser))) (METH ClassBrowser MoveIVTo (object objName) "Selected IV is moved to boxedNode" (category (ClassBrowser))) (METH ClassBrowser MoveMethodTo (object objName) "Moves selected method to boxed node" (category (ClassBrowser))) (METH ClassBrowser MoveSuperTo (object objName) "Substitute the boxed node for the selected super in the list of items" (category (ClassBrowser ))) (METH ClassBrowser NewItem (name) "Either add named class, or create a class by that Name" (category (LatticeBrowser))) (METH ClassBrowser PrintCategories (object objName) "Let the user select the category of the methods to edit" (category (ClassBrowser))) (METH ClassBrowser RenameCV (object objName) "Rename CV if one is given" (category (ClassBrowser))) (METH ClassBrowser RenameClass (object objName) "Read in a new name for the class, and rename it" (category (ClassBrowser))) (METH ClassBrowser RenameIV (object objName) "Rename an IV if one is given" (category (ClassBrowser))) (METH ClassBrowser RenameMeth (object objName) "Rename selected method" (category (ClassBrowser))) (METH ClassBrowser RenamePart (object objName) "Ask user whether to rename CVs IVs or Methods or class and then find which ones" (category ( ClassBrowser ))) (METH ClassBrowser RetireMethod (object objName) "Rename selected method to the same name but with Old prefix" (category (ClassBrowser))) (METH ClassBrowser SetItNew (class) "Set IT to instance of selected class" (category (ClassBrowser))) (METH ClassBrowser WhereIsCV (obj objName) "Whereis CV" (category (ClassBrowser))) (METH ClassBrowser WhereIsIV (obj objName) "Find class containing IV description" (category (ClassBrowser))) (METH ClassBrowser WhereIsMethod (obj objName) "Where is method" (category (ClassBrowser))) (Method ((ClassBrowser AddCategoryMenu) self) (* ; "smL 8-Apr-87 19:34") "Add a menu to the browser for specifying what method categories should be viewed" (LET [(oldMenu (WINDOWPROP (@ window) 'CategoryMenu] (if oldMenu then (CLOSEW oldMenu))) [LET [(items (LET [(cats (for class in (_ self BrowserObjects) join (_ class AllMethodCategories '(Any Public))] (SORT (INTERSECTION cats cats] (if items then (LET [(menuWindow (MENUWINDOW (_ self MakeParameterMenu (create MENU ITEMS _ (APPEND '(Any Public) (DREMOVE 'Any (DREMOVE 'Public items))) TITLE _ "Method Categories") [FUNCTION (LAMBDA (self test-value) (MEMB test-value (@ viewingCategories) ] [FUNCTION (LAMBDA (self new-value) (change (@ viewingCategories) (if (MEMB new-value DATUM) then (REMOVE new-value DATUM) else (CONS new-value DATUM])] (WINDOWPROP (@ window) 'CategoryMenu menuWindow) (ATTACHWINDOW menuWindow (@ window) 'LEFT 'TOP 'LOCALCLOSE) (OPENW menuWindow]) (Method ((ClassBrowser MessageFormForProcess) self obj selector args) (* ; "smL 8-Apr-87 13:39") "Create a form to evaluate in a new process that will send the obj the selector message with the given args" (* ;; "Viewed-Categories is bound to restrict the viewed categories to those that this browser is interested in") (LIST 'WithCategories (@ viewingCategories) (_Super ))) (Method ((ClassBrowser AddNewCV) self object objName) (* ; "smL 14-Jan-87 15:16") "Add a new CV or edit an old one" [PROG (cvForm (cvName (_ self PromptRead "Please tell me the name of the CV."))) (COND ((NULL cvName) (RETURN NIL)) ((MEMB cvName (_ object ListAttribute 'CVS)) (RINGBELLS) (_ self PromptPrint (CONCAT objName " already has CV " cvName)) (RETURN NIL))) [SETQ cvForm `(,cvName **DefaultValue ,@(COND ((NOT (_ object HasCV cvName 'doc)) `(doc (,COMMENTFLG CV added by ,(USERNAME NIL T] LP (SETQ cvForm (DEDITE cvForm NIL objName 'CLASSES)) (COND ((OddLengthList (CDDR cvForm)) (GO LP))) (LET ((UpdateClassBrowsers? NIL)) (DECLARE (SPECVARS UpdateClassBrowsers?)) (_ object AddCV (CAR cvForm) (CADR cvForm)) (for P on (CDDR cvForm) by (CDDR P) do (PutClassValue object (CAR cvForm) (CADR P) (CAR P]) (Method ((ClassBrowser AddNewIV) self object objName) (* ; "smL 18-Sep-86 11:28") "Add a new IV or edit an old one" (PROG (ivForm (ivName (_ self PromptRead "Please tell me the name of the IV."))) (COND ((NULL ivName) (RETURN NIL)) ((_ object HasIV ivName) (RINGBELLS) (_ self PromptPrint (CONCAT objName " already has IV " ivName)) (RETURN NIL))) [SETQ ivForm `(,ivName **DefaultValue doc (,COMMENTFLG IV added by ,(USERNAME NIL T] LP (SETQ ivForm (DEDITE ivForm NIL objName 'CLASSES)) (OR [LET ((UpdateClassBrowsers? NIL)) (ERSETQ (AddCIV object (CAR ivForm) (CADR ivForm) (CDDR ivForm] (GO LP)))) (Method ((ClassBrowser AddNewMethod) self obj objName) (* ; "smL 18-Sep-86 11:29") "Calls class facility. Allows specialization of Adding Methods in subclasses Used to be called AddMethod" (LET ((selector (_ self PromptRead "Type the selector for the new method: "))) (if [AND selector (OR [NOT (FMEMB selector (_ obj ListAttribute 'Methods)] (MOUSECONFIRM (CONCAT selector " already exists as a method. Do you want to overwrite?" ) NIL (_ self GetPromptWindow)] then (LET ((UpdateClassBrowsers NIL)) (_ obj DefMethod selector)) else (_ self PromptPrint "No method defined.")))) (Method ((ClassBrowser AddSpecializedMethod) self obj objName file) (* ; "smL 18-Sep-86 12:54") "Specialize a method of the class" (LET ((UpdateClassBrowsers NIL)) (_ obj SpecializeMethod NIL file))) (Method ((ClassBrowser AddSuper) self obj objName) (* ; "smL 17-Apr-86 13:43") "Add a super as first" [LET ((superName (_ self PromptRead "Type in name of new super"))) (COND ((NULL superName) (_ self PromptPrint "Nothing Added")) ((NOT (type? class ($! superName))) (_ self PromptPrint superName " not a class, nothing added")) ((FMEMB superName (GetSourceSupers obj)) (_ self PromptPrint (CONCAT superName " is already super of class."))) (T (InstallSupers obj (CONS superName (GetSourceSupers obj))) (ChangedClass obj]) (Method ((ClassBrowser BoxNode) self object objName) (* ; "dgb: 30-Nov-84 16:50") "Box selected node and unbox previous" (_Super self BoxNode object objName T)) (Method ((ClassBrowser CVDoc) self class className) (* ; "smL 9-Apr-87 19:21") "Show menu of classVariables and give documentation for each" (PROG (choice menu (vbls (_ class ListAttribute! 'CVS)) (outFile (PPDefault NIL))) (COND ((NULL vbls) (PROMPTPRINT (CHARACTER 7) " No Class Variables found for " className) (RETURN NIL))) (SETQ menu (_ self ItemMenu vbls (CONCAT "CV documentation: " className))) LP (COND ((NULL (SETQ choice (MENU menu))) (RETURN NIL))) (printout outFile T T className "::" choice ": " (GetClassValue class choice 'doc)) (GO LP))) (Method ((ClassBrowser ClassDoc) self object objname) (* ; "smL 9-Apr-87 19:21") "Print out class documentation if there is any" [LET ((doc (GetClassHere object 'doc)) (outFile (PPDefault NIL))) (COND ((NotSetValue doc) (printout outFile T objname " has no documentation." T)) (T (printout outFile T objname ": " doc T]) (Method ((ClassBrowser CopyCVTo) self object objName) (* ; "smL 8-Apr-87 18:35") "Selected CV is moved to boxed node" (if (NOT (Class? (@ boxedNode))) then (_ self PromptPrint "Select a target class first") else (PROG [item (items (ItemsForType self object objName 'CVs] LP (COND ((NULL items) (RETURN NIL))) (COND ([NULL (SETQ item (NiceMenu items (CONCAT objName " CVs"] (RETURN NIL))) (_ object CopyCV item (@ boxedNode)) (_ self PromptPrint (CONCAT "CV " item " has been copied to " (@ boxedNode))) (SETQ items (DREMOVE item items)) (GO LP)))) (Method ((ClassBrowser CopyIVTo) self object objName) (* ; "smL 8-Apr-87 18:35") "Copy the selected IV to the boxed node" (if (NOT (Class? (@ boxedNode))) then (_ self PromptPrint "Select a target class first") else (PROG [item (items (ItemsForType self object objName 'IVs] LP (COND ((NULL items) (RETURN NIL))) (COND ([NULL (SETQ item (NiceMenu items (CONCAT objName " IVs"] (RETURN NIL))) (_ object CopyIV item (@ boxedNode)) (_ self PromptPrint (CONCAT "IV " item " has been copied to " (@ boxedNode))) (SETQ items (DREMOVE item items)) (GO LP)))) (Method ((ClassBrowser CopyMethodTo) self object objName) (* ; "smL 8-Apr-87 18:35") "Selected Method is copied to boxedNode" (if (NOT (Class? (@ boxedNode))) then (_ self PromptPrint "Select a target class first") else (PROG (item) LP (SETQ item (_ object PickSelector (CONCAT objName " Methods"))) (COND ((NULL item) (RETURN NIL))) (_ object CopyMethod item (@ boxedNode) (COND [(EQ object (@ boxedNode)) (* ;;  "ask for a new selector item if method is being copied to same class") (OR (_ self PromptRead "Tell me new selector name") (RETURN (PROMPTPRINT "Not copied"] (T item))) (_ self PromptPrint (CONCAT "Method " item " has been copied to " (@ boxedNode))) (GO LP)))) (Method ((ClassBrowser DefineSubclass) self object objName) (* ; "smL 5-Mar-85 14:24") "Define a new subclass, giving it a name typed in by user" [PROG (className) (COND ((SETQ className (_ self PromptRead "Type in the name of the new class, or NIL for none.") ) [COND [(NOT (LITATOM className)) (RETURN (_ self PromptPrint (CONCAT className " should be an atom to name a class")) ] ((Class? ($! className)) (OR (EQ T (_ self PromptRead "Class by that name exists Type T to destroy it:")) (RETURN (_ self PromptPrint "Aborted")] (_ object Specialize className)]) (Method ((ClassBrowser DeleteCVUsingBrowser) self obj objName) (* ; "dgb: 2-Feb-85 06:26") "Delete selected CV" (_ self DeleteClassItem obj objName 'CVs)) (Method ((ClassBrowser DeleteClass) self obj objName) (* ; "dgb: 15-DEC-83 08:12") "Delete Class" (_ self DeleteClassItem obj objName 'Class)) (Method ((ClassBrowser DeleteClassItem) self class className type) (* ; "smL 11-Apr-86 14:55") "Delete an item from a class, or the class itself" (PROG (choice choices) (OR type [SETQ type (MENU (MenuGetOrCreate ClassChoiceMenu '(IVs CVs Methods Class] (RETURN)) (* ;; "If we're deleting the Class, don't look for choices; just nuke it") (AND (EQ type 'Class) (RETURN (_ self DestroyAndRecompute class className))) (* ;; "Otherwise get a list of what we can delete; die if there aren't any...") (OR (SETQ choices (SORT (_ class ListAttribute type))) (PROMPTPRINT " No items for " className " of type " type ". ") (RETURN)) (OR [SETQ choice (NiceMenu choices (CONCAT "Deleting " type ": " (ClassName class] (RETURN)) (SELECTQ type (IVs (_ class Delete 'IV choice)) (CVs (_ class Delete 'CV choice)) (Methods (AND [MENU (create MENU TITLE _ (CONCAT choice "Confirm method deletion") ITEMS _ '(("Delete Method and Function" T "Delete method and function definition") ("Abort" NIL "Don't delete anything"] (_ class Delete 'Method choice T))) (LoopsHelp type " wrong in DeleteClassItem.")))) (Method ((ClassBrowser DeleteIVUsingBrowser) self obj objName) (* ; "dgb: 2-Feb-85 06:25") "Delete selected IV" (_ self DeleteClassItem obj objName 'IVs)) (Method ((ClassBrowser DeleteMethodUsingBrowser) self obj objName) (* ; "smL 12-Feb-85 17:52") "Delete selected Method" (_ self DeleteClassItem obj objName 'Methods)) (Method ((ClassBrowser DestroyAndRecompute) self object objName) (* ; "smL 26-Feb-86 17:57") "Destroy class and recompute lattice." (AND [MENU (create MENU TITLE _ 'Confirm ITEMS _ (LIST (CONCAT "Destroy " objName] (PROGN (_ object Destroy) (_ self DeleteFromBrowser object) T))) (Method ((ClassBrowser EditCategory) self object objName) (* ; "smL 13-May-86 13:30") "Let the user select the category of the methods to edit" [LET ((cat (NiceMenu (for cat in (_ object AllMethodCategories '(Any Public Internal)) collect (LIST cat)) "Method category"))) (if cat then (LET ((sel (_ object PickSelector "Edit method: " cat))) (if sel then (_ object EditMethod sel)]) (Method ((ClassBrowser FindWhere) self object objName type) (* ; "smL 5-Sep-86 12:47") "Ask user whether CVs IVs or Methods wanted and then find that one" [LET* [[type (OR type (MENU (LOADTIMECONSTANT (create MENU ITEMS _ '(IVS CVS Methods] (items (AND type (_ object ListAttribute! type NIL (_ object Subclass ($ Class)))] (if (NULL type) then NIL elseif (NULL items) then (PROMPTPRINT (CONSTANT (CHARACTER 7)) objName " has no " type) else (bind (menu _ (_ self ItemMenu (SORT items) (CONCAT "Finding " type ": " objName))) (browsedClasses _ (_ self BrowserObjects)) value name anyWhere while (SETQ name (MENU menu)) do (SETQ value (_ object WhereIs name type)) (SETQ anyWhere (for class in browsedClasses when (SELECTQ type (IVS (MEMB name (fetch (class localIVs) of class))) (CVS (MEMB name (APPEND (fetch cvNames of class)))) (Methods (FindLocalMethod class name)) NIL) collect class)) (for class in anyWhere do (_ self ShadeNode class GRAYSHADE1)) (_ self FlashNode value) (_ self ClearPromptWindow) (_ self PromptPrint (CONCAT (SELECTQ type (IVS "IV") (CVS "CV") (Methods 'Method) type) " " name " is in " value)) (for class in anyWhere do (_ self ShadeNode class WHITESHADE)]) (Method ((ClassBrowser GetMethodDoc) self object objName) (* ; "smL 31-Oct-86 10:33") "Find the method requested and then ask the class" (* ;;; "") (bind selector eachtime (SETQ selector (_ object PickSelector (CONCAT "GetMethodDoc: " objName))) while selector do (_ object MethodDoc selector))) (Method ((ClassBrowser GetSubs) self obj objName) (* ; "mjs: 31-Aug-84 16:18") "Returns subclasses of a class on goodlist If goodlist is NIL take everyone you come to who is not bad. any" (for C in (_ obj SubClasses) when (OR (NULL (@ goodList)) (FMEMB C (@ goodList)) (FMEMB (GetObjectRec C) (@ goodList))) collect (GetObjectRec C))) (Method ((ClassBrowser IVDoc) self class className) (* ; "smL 9-Apr-87 19:21") "Show menu of classVariables and give documentation for each" (PROG (choice menu (vbls (_ class ListAttribute! 'IVS)) (outFile (PPDefault NIL))) (COND ((NULL vbls) (PROMPTPRINT (CHARACTER 7) " No Instance Variables found for " className) (RETURN NIL))) (SETQ menu (_ self ItemMenu vbls (CONCAT "IV documentation: " className))) LP (COND ((NULL (SETQ choice (MENU menu))) (RETURN NIL))) (printout outFile T T className ":" choice ": " (GetClassIV class choice 'doc)) (GO LP))) (Method ((ClassBrowser LeftShiftSelect) self object objname) "Called when item is selected with left key and LSHIFT is down" (_ object PP!)) (Method ((ClassBrowser MethodMenu) self object objName) (* ; "smL 1-Jul-85 17:59") "make a menu for editing this classes methods" (LET ((menuWindow (MakeMethodMenu object))) (if (WINDOWP menuWindow) then (MOVEW menuWindow) else (_ self PromptPrint "No methods defined for class")))) (Method ((ClassBrowser MoveCVTo) self object objName) (* ; "smL 8-Apr-87 18:35") "Move the selected CV to boxedNode" [if (NOT (Class? (@ boxedNode))) then (_ self PromptPrint "Select a target class first") else (bind item (items _ (ItemsForType self object objName 'CVs)) while items do (SETQ item (NiceMenu items (CONCAT objName "CVs"))) (if (NULL item) then (RETURN NIL)) (MoveClassVariable objName (ClassName (@ boxedNode)) item) (_ self PromptPrint (CONCAT "CV " item " is now in " (@ boxedNode))) (SETQ items (DREMOVE item items]) (Method ((ClassBrowser MoveIVTo) self object objName) (* ; "smL 8-Apr-87 18:35") "Selected IV is moved to boxedNode" (if (NOT (Class? (@ boxedNode))) then (_ self PromptPrint "Select a target class first") else (PROG [item (items (ItemsForType self object objName 'IVs] LP (COND ((NULL items) (RETURN NIL))) (COND ([NULL (SETQ item (NiceMenu items (CONCAT objName "IVs"] (RETURN NIL))) (MoveVariable objName (ClassName (@ boxedNode)) item) (_ self PromptPrint (CONCAT "IV " item " is now in " (@ boxedNode))) (SETQ items (DREMOVE item items)) (GO LP)))) (Method ((ClassBrowser MoveMethodTo) self object objName) (* ; "smL 8-Apr-87 18:35") "Moves selected method to boxed node" (if (NOT (Class? (@ boxedNode))) then (_ self PromptPrint "Select a target class first") else (PROG (item) LP (SETQ item (_ object PickSelector (CONCAT objName " Methods"))) (COND ((NULL item) (RETURN NIL))) (MoveMethod objName (ClassName (@ boxedNode)) item item) (_ self PromptPrint (CONCAT "Method " item " is now in " (@ boxedNode))) (GO LP)))) (Method ((ClassBrowser MoveSuperTo) self object objName) (* ; "smL 8-Apr-87 18:35") "Substitute the boxed node for the selected super in the list of items" [if (NOT (Class? (@ boxedNode))) then (_ self PromptPrint "Select a target class first") else (LET [item (items (ItemsForType self object objName 'Supers] (COND ((NULL items) NIL) ([NULL (SETQ item (NiceMenu items (CONCAT objName "Supers"] NIL) (T (_ object ReplaceSupers (SUBST (ClassName (@ boxedNode)) item items))]) (Method ((ClassBrowser NewItem) self name) (* ; "smL 13-Aug-86 18:31") "Either add named class, or create a class by that Name" [LET ((newItem (_Super self NewItem name))) (COND ((Object? newItem) newItem) (($! newItem)) ((AND newItem (CL:SYMBOLP newItem) (MOUSECONFIRM (CONCAT "About to create class named " newItem) NIL (_ self GetPromptWindow))) (_ ($ Class) New newItem)]) (Method ((ClassBrowser PrintCategories) self object objName) (* ; "smL 9-Apr-87 19:22") "Let the user select the category of the methods to edit" [LET ((cats (_ object AllMethodCategories)) (outFile (PPDefault NIL)) temp) (RESETLST (RESETSAVE NIL (LIST (FUNCTION DSPFONT) (DSPFONT NIL outFile) outFile)) (WITH.PP.OUTPUT outFile (printout outFile T T .FONT LAMBDAFONT " " object T) (for cat in cats when (LITATOM cat) do (printout outFile T .FONT BOLDFONT cat T .FONT DEFAULTFONT .TAB 5) (for sel in (_ object SelectorsInCategories (LIST cat)) do (printout outFile sel %,)) (printout outFile T)) (for cat in cats when (LISTP cat) do (printout outFile T .FONT BOLDFONT cat T .FONT DEFAULTFONT .TAB 5) (for sel in (_ object SelectorsInCategories (LIST cat)) do (printout outFile sel %,)) (printout outFile T))))]) (Method ((ClassBrowser RenameCV) self object objName) (* ; "smL 11-Apr-86 14:55") "Rename CV if one is given" (PROG (name items newName) (COND ([NULL (SETQ items (_ object ListAttribute 'CVs)] (_ self PromptPrint (CONCAT objName " has no Class Variables")) (RETURN))) (OR [SETQ name (MENU (_ self ItemMenu (SORT items) (CONCAT (ClassName object) " CVs"))] (RETURN NIL)) (AND (SETQ newName (_ self PromptRead "New CV name:")) (RenameVariable objName name newName T)))) (Method ((ClassBrowser RenameClass) self object objName) (* ; "smL 29-Sep-86 18:33") "Read in a new name for the class, and rename it" [LET ((className (_ self PromptRead "Type in the new name for this class, or NIL not to change."))) (COND (className (LET ((UpdateClassBrowsers? NIL)) (_ self PromptPrint (CONCAT "Renaming " (ClassName object) " to " className "...")) (BLTSHADE HIGHLIGHTSHADE (@ window) NIL NIL NIL NIL 'PAINT) (_ object Rename className)) (pushnew ClassBrowsersThatNeedUpdating self) (UpdateClassBrowsers T) (_ self PromptPrint "Rename completed")]) (Method ((ClassBrowser RenameIV) self object objName) (* ; "smL 11-Apr-86 14:55") "Rename an IV if one is given" (PROG (items name newName) (COND ([NULL (SETQ items (_ object ListAttribute 'IVs)] (_ self PromptPrint (CONCAT objName " has no Instance Variables")) (RETURN))) (OR [SETQ name (MENU (_ self ItemMenu (SORT items) (CONCAT (ClassName object) " IVs"))] (RETURN NIL)) (AND (SETQ newName (_ self PromptRead "New IV name:")) (RenameVariable objName name newName)))) (Method ((ClassBrowser RenameMeth) self object objName) (* ; "smL 14-Jan-87 09:32") "Rename selected method" [LET* ((name (_ object PickSelector (CONCAT "Renaming Methods: " objName))) (newName (AND name (_ self PromptRead "New Selector Name:"))) (UpdateClassBrowsers? NIL)) (if newName then (_ object RenameMethod name newName) (_ self PromptPrint (CONCAT "Method " name " renamed to " newName))]) (Method ((ClassBrowser RenamePart) self object objName) (* ; "smL 11-Apr-86 14:56") "Ask user whether to rename CVs IVs or Methods or class and then find which ones" (PROG (name newName type value items flg) (OR [SETQ type (MENU (create MENU ITEMS _ '(IVS CVS Methods Class] (RETURN NIL)) LP (SELECTQ type (Class (RETURN (_ self RenameClass object objName))) ((IVS CVS Methods)) (RETURN NIL)) (COND ((NULL (SETQ items (_ object ListAttribute type))) (OR flg (_ self PromptPrint (CONCAT objName " has no " type))) (RETURN))) (* So that when last IV is removed, no  comment is made) (SETQ flg T) (OR [SETQ name (MENU (_ self ItemMenu (SORT items) (CONCAT (ClassName object) " " type))] (RETURN NIL)) (SELECTQ type (IVS (AND (SETQ newName (_ self PromptRead "New IV name:")) (RenameVariable objName name newName))) (CVS (AND (SETQ newName (_ self PromptRead "New CV name:")) (RenameVariable objName name newName T))) (Methods (AND (SETQ newName (_ self PromptRead "New Selector Name:")) (_ object RenameMethod name newName))) NIL) (GO LP))) (Method ((ClassBrowser RetireMethod) self object objName) (* ; "smL 14-Jan-87 09:31") "Rename selected method to the same name but with Old prefix" (bind name newName eachtime (SETQ name (_ object PickSelector (CONCAT "Renaming Methods: " objName ))) while name do (SETQ newName (PACK* "Old" name)) (_ object RenameMethod name newName) (_ self PromptPrint (CONCAT "Method " name " renamed to " newName)))) (Method ((ClassBrowser SetItNew) self class) (* ; "smL 5-Aug-86 17:40") "Set IT to instance of selected class" (LET ((value (_ class New))) (PutSavedValue value) (PRINT value T) value)) (Method ((ClassBrowser WhereIsCV) self obj objName) (* ; "dgb: 15-DEC-83 07:59") "Whereis CV" (_ self FindWhere obj objName 'CVS)) (Method ((ClassBrowser WhereIsIV) self obj objName) (* ; "dgb: 14-Feb-84 13:51") "Find class containing IV description" (_ self FindWhere obj objName 'IVS)) (Method ((ClassBrowser WhereIsMethod) self obj objName) (* ; "dgb: 15-DEC-83 08:00") "Where is method" (_ self FindWhere obj objName 'Methods)) (\UnbatchMethodDefs) (DEFINEQ (ClassBrowserMarkChanged [LAMBDA (name type reason) (* ; "Edited 15-Mar-88 15:00 by jrb:") (* ;;; "Something has been MARKASCHANGEd. Make sure all class browsers are up to date.") (* ;; "If something is DELETED, we have to recompute the world... *sigh*...") (SELECTQ type (CLASSES [for browser in (_ ($ ClassBrowser) AllInstances!) bind (classobj _ ($! name)) when (OR (EQ reason 'DELETED) (_ browser CareAbout? classobj)) do (COND ((\Loading-File?) (* ; "do it later") (pushnew ClassBrowsersThatNeedUpdating browser)) ((NOT (UpdateClassBrowsers?)) (if (EQ UpdateClassBrowsers? 'SHADE) then (_ browser Shade))) ((_ browser Open?) (SELECTQ reason ((NIL CHANGED) (_ browser RecomputeLabels)) (_ browser Recompute)]) NIL]) (UpdateClassBrowsers [LAMBDA (newLabels?) (* ; "Edited 15-Mar-88 14:59 by jrb:") (* ;;; "Update all the classBrowsers on the screen that have been marked as needing update. If UpdateClassBrowsers? is SHADE, just shade them.") (if (AND UpdateClassBrowsers? (NOT (\Loading-File?))) then [for lw in ClassBrowsersThatNeedUpdating when (AND (_ lw InstOf! 'ClassBrowser) (_ lw Open?)) do (if (EQ UpdateClassBrowsers? 'SHADE) then (_ lw Shade) else (if newLabels? then (_ lw RecomputeLabels) else (_ lw Recompute)] (SETQ ClassBrowsersThatNeedUpdating NIL]) ) (RPAQ? ClassBrowsersThatNeedUpdating NIL) (RPAQ? UpdateClassBrowsers? T) (DEFMACRO UpdateClassBrowsers? () (* ;;; "Should any open class browsers be updated?") `(EQ UpdateClassBrowsers? T)) (DEFMACRO WithCategories (categories &BODY forms) `(LET [(Viewed-Categories ',categories] ,@forms)) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS ClassBrowsersThatNeedUpdating) ) (DECLARE%: DOEVAL@COMPILE DONTCOPY (SPECVARS UpdateClassBrowsers?) ) (ADDTOVAR MARKASCHANGEDFNS ClassBrowserMarkChanged) (* ;;; "File browser") (\BatchMethodDefs) (METH FileBrowser AddFile (fileName) "Add a file to the list of associated files for this FIleBrowser." (category (FileBrowser))) (METH FileBrowser AddNewMethod (obj objName) "Overwrites ClassBrowser AddNewMethod giving file argument to DefMethod." (category ( ClassBrowser ))) (METH FileBrowser AddSpecializedMethod (obj objName file) "Specialization" (category (ClassBrowser))) (METH FileBrowser AddSubs (obj objName) "Add the Subs of the class to the nonFileClasses if they are not on the file" (category ( FileBrowser ))) (METH FileBrowser AddSubs! (obj objName) "Add all the Subs of the class to the nonFileClasses if they are not on the file" (category (FileBrowser ))) (METH FileBrowser BreakFunction NIL "Choose a function from the file and BREAK it" (category (FileBrowser))) (METH FileBrowser BrowseFile (fileName) "Browse classes contained on the selectedFile" (category (FileBrowser))) (METH FileBrowser ChangeDisplayMode (obj objName) "New method template" (category (FileBrowser))) (METH FileBrowser CollectMethodList (object) "Returns list of functions for file or object" (category (FileBrowser))) (METH FileBrowser DefineSubclass (object objName) "Define a new subclass, giving it a name typed in by user" (category (ClassBrowser))) (METH FileBrowser EditComs NIL "Edit the coms for file" (category (FileBrowser))) (METH FileBrowser EditFns NIL "Choose a Function and Edit it" (category (FileBrowser))) (METH FileBrowser EditInstances NIL "Select from the set of instances" (category (FileBrowser))) (METH FileBrowser EditMacros NIL "Edit a selected Macro definition" (category (FileBrowser))) (METH FileBrowser EditRecords NIL "Edit a selected Record definition" (category (FileBrowser))) (METH FileBrowser EditVars NIL "Edit a selected variable" (category (FileBrowser))) (METH FileBrowser File (fileName) "Browse classes contained on the file" (category (FileBrowser))) (METH FileBrowser IconTitle NIL "compute the label to use in the icon -- in the file browser case, it should just be the selected file" (category (LatticeBrowser))) (METH FileBrowser ListFile (file) "Make a hardcopy of the file" (category (FileBrowser))) (METH FileBrowser LoadPropFile (file) "Load the file with LDFLG = PROP" (category (FileBrowser))) (METH FileBrowser LoadAllPropFile (file) "Load the file with LDFLG = ALLPROP" (category (FileBrowser))) (METH FileBrowser LoadFnsPropFile (file) "Load the fns from the file with LDFLG = PROP" (category (FileBrowser))) (METH FileBrowser MakeFunctionMenu NIL "Build a standalone edit menu for functions on a file" (category (FileBrowser))) (METH FileBrowser NewItem (name) "Either add named class, or create a class by that Name" (category (LatticeBrowser))) (METH FileBrowser Recompute (dontReshapeFlg) "Recompute what the classes are on the file. Operations are different for the different display modes" (category (LatticeBrowser))) (METH FileBrowser SaveFile NIL "Save file for file browser" (category (FileBrowser))) (METH FileBrowser SelectFile (fileName) "Select one of Associated files for focus" (category (FileBrowser))) (METH FileBrowser SetItNew (obj objName) "Save value in IT and in SavedValue of LoopsIcon. Put UID on list of INSTANCES to be saved" (category (ClassBrowser))) (METH FileBrowser SubBrowser (obj objName) "Specialization" (category (LatticeBrowser))) (METH FileBrowser TraceFunction NIL "Choose a function from the file and TRACE it" (category (FileBrowser))) (METH FileBrowser UnbreakFunction NIL "New method template" (category (FileBrowser))) (Method ((FileBrowser AddFile) self fileName) (* ; "smL 20-Aug-86 13:08") "Add a file to the list of associated files for this FIleBrowser." [LET [(fileName (OR fileName (SelectFile] (COND ((NOT (FMEMB fileName (@ associatedFiles))) (_@ associatedFiles (CONS fileName (@ associatedFiles))) (AND (EQ (@ displayMode) 'associatedFiles) (_ self Recompute)]) (Method ((FileBrowser AddNewMethod) self obj objName) (* ; "smL 13-Aug-86 18:32") "Overwrites ClassBrowser AddNewMethod giving file argument to DefMethod." (LET ((selector (_ self PromptRead "Type the selector for the new method: "))) (if [AND selector (OR [NOT (FMEMB selector (_ obj ListAttribute 'Methods)] (MOUSECONFIRM (CONCAT selector " already exists as a method. Do you want to overwrite?" ) NIL (_ self GetPromptWindow)] then (_ obj DefMethod selector NIL NIL (@ selectedFile)) else (_ self PromptPrint "No method defined.")))) (Method ((FileBrowser AddSpecializedMethod) self obj objName file) (* ; "dgb: 15-Oct-84 11:21") "Specialization" (_Super self AddSpecializedMethod obj objName (OR file (@ selectedFile)))) (Method ((FileBrowser AddSubs) self obj objName) (* ; "smL 5-Aug-86 16:51") "Add the Subs of the class to the nonFileClasses if they are not on the file" (for X in (MAPCAR (_ obj ListAttribute 'Subs) (FUNCTION $!)) when (NOT (MEMB X (@ startingList))) do (pushnew (@ nonFileClasses) X)) (_ self Recompute)) (Method ((FileBrowser AddSubs!) self obj objName) (* ; "smL 19-Aug-86 12:43") "Add all the Subs of the class to the nonFileClasses if they are not on the file" (for X in (MAPCAR (_ obj ListAttribute! 'Subs) (FUNCTION $!)) when (NOT (MEMB X (@ startingList))) do (pushnew (@ nonFileClasses) X)) (_ self Recompute)) (Method ((FileBrowser BreakFunction) self) (* ; "smL 9-Oct-85 17:37") "Choose a function from the file and BREAK it" [PROG [choice (fns (SORT (LDIFFERENCE (LDIFFERENCE (FILEFNSLST (@ selectedFile)) (FILECOMSLST (@ selectedFile) 'METHODS)) BROKENFNS] (if (NULL fns) then (_ self PromptPrint "No functions to break") (RETURN)) (SETQ choice (MENU (_ self ItemMenu fns "Break function"))) (RETURN (AND choice (APPLY* 'BREAK choice]) (Method ((FileBrowser BrowseFile) self fileName) (* ; "dgb: 7-Sep-84 17:14") "Browse classes contained on the selectedFile" (PROG (classes fileComs) (COND ([AND (NULL fileName) (NULL (SETQ fileName (SelectFile] (* No file given) (RETURN))) (SETQ fileName (U-CASE fileName)) (_@ associatedFiles (LIST fileName)) (_ self SelectFile fileName) (_ self ShapeToHold) (RETURN self))) (Method ((FileBrowser ChangeDisplayMode) self obj objName) (* ; "dgb: 7-Sep-84 17:24") "New method template" [PROG [(mode (MENU (MenuGetOrCreate FileBrowserMenuModes '(selectedFile associatedFiles all] (COND ((AND mode (NEQ mode (@ displayMode))) (_@ displayMode mode) (_ self Recompute)]) (Method ((FileBrowser CollectMethodList) self object) (* ; "smL 11-Apr-86 14:58") "Returns list of functions for file or object" [COND (object (_ object ListAttribute 'Functions)) (T (FILEFNSLST (@ selectedFile)]) (Method ((FileBrowser DefineSubclass) self object objName) (* ; "smL 9-Apr-87 18:28") "Define a new subclass, giving it a name typed in by user" [LET ((className (_ self PromptRead "Type in the name of the new class, or NIL for none."))) (COND ((NULL className) (* Abort, since no new name given) NIL) ((NOT (LITATOM className)) (* ; "Name must be a litatom") (_ self PromptPrint (CONCAT className " should be an atom to name a class"))) (T (* ; "Create the specialization") (_ object Specialize className) (* ; "Figure out what file to put it on") (LET ((objectFiles (WHEREIS (ClassName object) 'CLASS)) outfile) (pushnew objectFiles (@ selectedFile)) (if objectFiles then (COND ((EQLENGTH objectFiles 1) (ADDTOFILE className 'CLASSES (CAR objectFiles))) (T (* ;; "Prompt User if more than 1 likely place to file the new class. If he doesn't pick one, just leave it alone for (FILES?) ") (SETQ outfile (MENU (create MENU TITLE _ (CONCAT "Choose a file for " className) ITEMS _ objectFiles))) (AND outfile (ADDTOFILE className 'CLASSES outfile]) (Method ((FileBrowser EditComs) self) (* ; "dgb: 7-Sep-84 15:42") "Edit the coms for file" (APPLY* 'DV (FILECOMS (@ selectedFile)))) (Method ((FileBrowser EditFns) self) (* ; "smL 2-May-86 16:09") "Choose a Function and Edit it" (LET (choice (fns (@ menus%:,fns))) (if (NoValueFound fns) then (* not yet cached) [SETQ fns (SORT (LDIFFERENCE (FILEFNSLST (@ selectedFile)) (FILECOMSLST (@ selectedFile) 'METHODS] (change (@ menus%:,fns) fns)) [SETQ choice (MENU (_ self ItemMenu (CONS '*NewFunction* fns) (CONCAT (@ selectedFile) " Functions"))] [COND ((EQ choice '*NewFunction*) (AND (SETQ choice (_ self PromptRead "Please tell me the name of the new function")) (DEFINE (LIST (LIST choice NIL (LIST COMMENTFLG COMMENTFLG 'Comment) NIL))) (ADDTOFILE choice 'FNS (@ selectedFile)] (AND choice (APPLY* 'DF choice)))) (Method ((FileBrowser EditInstances) self) (* ; "kmk: 29-Nov-84 09:07") "Select from the set of instances" (PROG [choice (instances (LDIFFERENCE (FILECOMSLST (@ selectedFile) 'INSTANCES) (FILECOMSLST (@ selectedFile) 'METHODS] (AND instances [SETQ choice (MENU (_ self ItemMenu (MAPCAR instances (FUNCTION GetObjectRec) ) (CONCAT (@ selectedFile) " Instances"))] (_ choice Edit)))) (Method ((FileBrowser EditMacros) self) (* ; "smL 8-Feb-85 17:34") "Edit a selected Macro definition" [LET [choice (names (FILECOMSLST (@ selectedFile) 'MACROS] (AND names [SETQ choice (MENU (_ self ItemMenu names (CONCAT (@ selectedFile) " Macros"))] (EDITDEF choice 'MACROS]) (Method ((FileBrowser EditRecords) self) (* ; "smL 8-Feb-85 17:34") "Edit a selected Record definition" [LET [choice (names (FILECOMSLST (@ selectedFile) 'RECORDS] (AND names [SETQ choice (MENU (_ self ItemMenu names (CONCAT (@ selectedFile) " Records"))] (EDITDEF choice 'RECORDS]) (Method ((FileBrowser EditVars) self) (* ; "mjs: 31-Aug-84 12:00") "Edit a selected variable" (PROG [choice (vars (FILECOMSLST (@ selectedFile) 'VARS] (AND vars [SETQ choice (MENU (_ self ItemMenu vars (CONCAT (@ selectedFile) " Vars"))] (APPLY* 'DV choice)))) (Method ((FileBrowser File) self fileName) (* ; "smL 5-Dec-85 14:12") "Browse classes contained on the file" (SETQ fileName (U-CASE fileName)) (LET ((classes) (fileComs (FILECOMS fileName))) (_@ selectedFile fileName) (_@ selectedFile%:,fileComs fileComs) [COND ((NLISTP (GETTOPVAL fileComs)) (* ; "New file") (SETTOPVAL fileComs (COPY `((,COMMENTFLG File Created by ,(USERNAME NIL T)) (CLASSES) (METHODS) (FNS) (VARS) (INSTANCES] (SETQ classes (FILECLASSES fileName)) (_ self Show classes (CONCAT fileName " file browser") classes 'showEvenIfEmpty) (COND ((NULL (FILECOMSLST fileName 'CLASSES)) (* ;  "Need to move if no classes to intialize movement") (_ self Move))) self)) (Method ((FileBrowser IconTitle) self) (* ; "edited: 19-Jan-85 17:04") "compute the label to use in the icon -- in the file browser case, it should just be the selected file" (@ selectedFile)) (Method ((FileBrowser ListFile) self file) (* ; "smL 4-Jan-85 16:57") "Make a hardcopy of the file" [LISTFILES1 (CDAR (GETPROP (ROOTFILENAME (OR file (@ selectedFile))) 'FILEDATES]) (Method ((FileBrowser LoadPropFile) self file) (* ; "smL 14-Jan-87 10:38") "Load the file with LDFLG = PROP" (LET [(pwindow (_ self GetPromptWindow)) (file (FINDFILE (CDAR (GETPROP (ROOTFILENAME (OR file (@ selectedFile))) 'FILEDATES] (CLEARW pwindow) (if file then (printout pwindow "Loading " file " PROP...") (LOAD file 'PROP) (printout pwindow "done") file else (printout pwindow "Can't find file") NIL))) (Method ((FileBrowser LoadAllPropFile) self file) (* ; "smL 14-Jan-87 10:38") "Load the file with LDFLG = ALLPROP" (LET [(pwindow (_ self GetPromptWindow)) (file (FINDFILE (CDAR (GETPROP (ROOTFILENAME (OR file (@ selectedFile))) 'FILEDATES] (CLEARW pwindow) (if file then (printout pwindow "Loading " file " ALLPROP...") (LOAD file 'ALLPROP) (printout pwindow "done") file else (printout pwindow "Can't find file") NIL))) (Method ((FileBrowser LoadFnsPropFile) self file) (* ; "smL 14-Jan-87 10:39") "Load the fns from the file with LDFLG = PROP" (LET [(pwindow (_ self GetPromptWindow)) (file (FINDFILE (CDAR (GETPROP (ROOTFILENAME (OR file (@ selectedFile))) 'FILEDATES] (CLEARW pwindow) (if file then (printout pwindow "Loading fns from " file " PROP...") (LOADFNS T file 'PROP) (printout pwindow "done") file else (printout pwindow "Can't find file") NIL))) (Method ((FileBrowser MakeFunctionMenu) self) (* ; "dgb: 1-Feb-85 17:03") "Build a standalone edit menu for functions on a file" (LET* [window [fns (SORT (LDIFFERENCE (FILEFNSLST (@ selectedFile)) (FILECOMSLST (@ selectedFile) 'METHODS] (menu (create MENU ITEMS _ fns MENUCOLUMNS _ (IPLUS 1 (IQUOTIENT (FLENGTH fns) 35)) WHENSELECTEDFN _ 'FunctionMenuWhenSelectedFn TITLE _ (CONCAT "Edit functions for " (@ selectedFile)] (SETQ window (ADDMENU menu NIL)) (WINDOWPROP window 'file (@ selectedFile)) (MOVEW window))) (Method ((FileBrowser NewItem) self name) (* ; "smL 13-Aug-86 18:32") "Either add named class, or create a class by that Name" (LET* [(name (_ self PromptRead "Give name of item to be added")) (alreadyExistsFlg ($! name)) (new (OR alreadyExistsFlg (AND name (MOUSECONFIRM (CONCAT "About to create class named " name) NIL (_ self GetPromptWindow)) (_ ($ Class) New name)] (if (NULL new) then NIL elseif alreadyExistsFlg then (pushnew (@ nonFileClasses) new) else (ADDTOFILE (ClassName new) 'CLASSES (@ selectedFile))) new)) (Method ((FileBrowser Recompute) self dontReshapeFlg) (* ; "smL 14-Jan-87 10:14") "Recompute what the classes are on the file. Operations are different for the different display modes" [change (@ startingList) (SELECTQ (@ displayMode) (selectedFile (* only those in selected file) (APPEND (@ nonFileClasses) (for C in (FILECLASSES (@ selectedFile)) collect ($! C)))) ((associatedFiles all) (* all from all files) [APPEND (@ nonFileClasses) (for file in (@ associatedFiles) join (for C in (FILECLASSES file) collect ($! C]) (ERROR "Illegal displayMode " (@ displayMode)] [change (@ goodList) (SELECTQ (@ displayMode) ((selectedFile associatedFiles) (@ startingList)) (all NIL) (ERROR "Illegal displayMode " (@ displayMode)] (_Super ) (* ; "Shade classes not on this file") (if (@ goodList) then (for c in (@ nonFileClasses) do (_ self ShadeNode c GRAYSHADE1)) else (for c in (_ self BrowserObjects) bind [fileClasses _ (for file in (@ associatedFiles) join (for C in (FILECLASSES file) collect ($! C] when (NOT (MEMB c fileClasses)) do (_ self ShadeNode c GRAYSHADE1))) self) (Method ((FileBrowser SaveFile) self) (* ; "mjs: 31-Aug-84 12:08") "Save file for file browser" (* ;; "Do the ADD.PROCESS to open another window for the interaction") (ADD.PROCESS `(PROGN (FILES?) (CLEANUP ,(@ selectedFile)) (CLOSEW (TTYDISPLAYSTREAM))) 'NAME 'SaveFile 'BEFOREEXIT 'DON'T)) (Method ((FileBrowser SelectFile) self fileName) (* ; "dgb: 10-Sep-84 15:58") "Select one of Associated files for focus" [OR fileName (SETQ fileName (MENU (create MENU ITEMS _ (@ associatedFiles)] (COND (fileName (_@ selectedFile fileName) (_@ nonFileClasses NIL) (_@ badList NIL) (_@ title (CONCAT "File browser (selected file " fileName ")")) (_ self Recompute)))) (Method ((FileBrowser SetItNew) self obj objName) (* ; "smL 5-Aug-86 17:39") "Save value in IT and in SavedValue of LoopsIcon. Put UID on list of INSTANCES to be saved" (LET ((value (_Super )) (name (_ self PromptRead "New Instance name, or NIL for none."))) (AND name (_ value SetName name)) (ADDTOFILE (OR name (UID value)) 'INSTANCES (@ selectedFile)) value)) (Method ((FileBrowser SubBrowser) self obj objName) (* ; "smL 9-Oct-85 13:09") "Specialization" (_New ($ ClassBrowser) Browse obj)) (Method ((FileBrowser TraceFunction) self) (* ; "smL 9-Oct-85 17:36") "Choose a function from the file and TRACE it" [PROG [choice (fns (SORT (LDIFFERENCE (LDIFFERENCE (FILEFNSLST (@ selectedFile)) (FILECOMSLST (@ selectedFile) 'METHODS)) BROKENFNS] (if (NULL fns) then (_ self PromptPrint "No functions to trace") (RETURN)) (SETQ choice (MENU (_ self ItemMenu fns "Trace function"))) (RETURN (AND choice (APPLY* 'TRACE choice]) (Method ((FileBrowser UnbreakFunction) self) (* ; "smL 9-Oct-85 17:37") "New method template" [PROG [choice (fns (SORT (INTERSECTION (LDIFFERENCE (FILEFNSLST (@ selectedFile)) (FILECOMSLST (@ selectedFile) 'METHODS)) BROKENFNS] (if (NULL fns) then (_ self PromptPrint "No functions are broken") (RETURN)) (SETQ choice (MENU (_ self ItemMenu fns "Unbreak function"))) (RETURN (AND choice (APPLY* 'UNBREAK choice]) (\UnbatchMethodDefs) (DEFINEQ (FileBrowserMarkChanged [LAMBDA (name type reason) (* ; "Edited 15-Mar-88 14:56 by jrb:") (* * Something has been MARKASCHANGEd. Make sure all file browsers are up to  date.) (for browser in (_ ($ FileBrowser) AllInstances!) when (AND (_ browser Open?) (SELECTQ type (VARS (EQ name (FILECOMS (@ browser selectedFile)))) (FILEVARS (EQ name (@ browser selectedFile))) NIL)) do (DeleteIV browser 'menus 'fns) (COND ((\Loading-File?) (* ; "do it later") (pushnew ClassBrowsersThatNeedUpdating browser)) ((NOT (UpdateClassBrowsers?)) (if (EQ UpdateClassBrowsers? 'SHADE) then (_ browser Shade))) (T (_ browser Recompute)]) ) (ADDTOVAR MARKASCHANGEDFNS FileBrowserMarkChanged) (* ;;; "MasterScope methods") (\BatchMethodDefs) (METH FileBrowser AddAnalysisMenu (reportList itemName itemType title) "Create a menu of items in reportList. Variable itemType is the type of items in the list." (category (FileBrowser Masterscope))) (METH FileBrowser AnalyzeFile NIL "Analyze all the functions on the selected file" (category (FileBrowser Masterscope))) (METH FileBrowser CallsFunction (object objectName) "Analyze file for methods that send a given message" (category (FileBrowser Masterscope))) (METH FileBrowser CheckMenuItem (item itemType itemName) "Check an item from an analysis menu for this browser." (category (FileBrowser))) (METH FileBrowser CheckFile NIL "Do a MasterScope CHECK command on this file" (category (Masterscope))) (METH FileBrowser ComputeMenuItems (reportList) "Creates list of items with appropriate subitems for use in the analysis menu." (category (FileBrowser))) (METH FileBrowser EditMenuItem (item wait?) "New method template" (category (Masterscope))) (METH FileBrowser ImplementsMethod (object objectName) "Display menu of methods and classes that implement a method." (category (FileBrowser Masterscope))) (METH FileBrowser OverridesMethod (object objectName) "Analyze file for methods that override a given message" (category (FileBrowser Masterscope))) (METH FileBrowser SelectItemName (object itemType) "Prompt user for the name of an item (IV, CV, selector, etc.) -- either from the selected class or from any class in the browser." (category (Masterscope FileBrowser))) (METH FileBrowser SendsMessage (object objectName) "Analyze file for methods that send a given message" (category (FileBrowser Masterscope))) (METH FileBrowser SpecializesMethod (object objectName) "Display menu of methods and classes that specialize a method." (category (FileBrowser Masterscope))) (METH FileBrowser SubstituteMenuItem (item itemType oldAtom newAtom) "Substitute and edit an item from an analysis menu for this browser." (category (Masterscope))) (METH FileBrowser UsesCV (object objectName) "Analyze file for methods and classes that use a given CV" (category (FileBrowser Masterscope))) (METH FileBrowser UsesIV (object objectName) "Analyze file for methods and classes that use a given IV." (category (FileBrowser Masterscope) )) (METH FileBrowser UsesItem (object objectName itemType) "Generalized method (for IVS, CVS, OBJECTS, MESSAGES) for interaction about MASTERSCOPE analysis." (category (FileBrowser Masterscope))) (METH FileBrowser UsesLispVar (object objectName) "Analyze file for methods that and functions use a given lisp variable" (category (FileBrowser Masterscope) )) (METH FileBrowser UsesObject (object objectName) "Analyze file for methods and classes that use a given Object." (category (FileBrowser Masterscope))) (Method ((FileBrowser AddAnalysisMenu) self reportList itemName itemType title) (* ; "smL 12-Dec-86 13:44") "Create a menu of items in reportList. Variable itemType is the type of items in the list." (* ;;; "(_ |self| |ComputeMenuItems| |reportList|)") [LET* [(menuItems reportList) (numberMenuItems (LENGTH menuItems)) (menuColumns (IPLUS 1 (IQUOTIENT numberMenuItems 35] [COND ((GREATERP numberMenuItems 1) (* ;  "Add *EditAll* item if more than one item in the list.") (SETQ menuItems `(,@menuItems ,@(from (ADD1 (IREMAINDER numberMenuItems menuColumns)) to (SUB1 menuColumns) bind (DUMMYITEM _ (LIST "" NIL)) collect DUMMYITEM) (*EditAll* NIL NIL (SUBITEMS *EditAll* *SubstituteAll*] (COND (menuItems (LET ((menu (create MENU TITLE _ title ITEMS _ menuItems WHENSELECTEDFN _ 'UsesMenuWhenSelectedFn MENUCOLUMNS _ menuColumns)) menuWindow) (PUTMENUPROP menu 'itemType itemType) (PUTMENUPROP menu 'itemName itemName) [SETQ menuWindow (ADDMENU menu NIL (CREATEPOSITION [MIN (PLUS (@ left) (@ width)) (DIFFERENCE SCREENWIDTH (WIDTHIFWINDOW (fetch IMAGEWIDTH of menu] (MAX (@ bottom) 0] (* ;  "Make pointer to self so that menu edit commands can access promptwindow and file information.") (WINDOWPROP menuWindow 'LoopsFileBrowser self) (MOVEW menuWindow) menuWindow]) (Method ((FileBrowser AnalyzeFile) self) (* ; "mjs: 3-Dec-85 10:26") "Analyze all the functions on the selected file" [AND (_ self LoadMasterscope?) (PROGN (_ self PromptPrint (CONCAT "Analyzing " (@ selectedFile) " in separate process.")) (ADD.PROCESS `(PROGN [RESETVAR MSPRINTFLG NIL (MASTERSCOPE '(ANALYZE ANY IN ',(FILEFNSLST (@ selectedFile)] (_ ,self PromptPrint " Done analyzing.")) 'NAME 'MASTERSCOPE]) (Method ((FileBrowser CallsFunction) self object objectName) (* ; "mjs: 10-Dec-85 09:35") "Analyze file for methods that send a given message" [LET* ((itemType 'FUNCTION) (itemName (_ self SelectItemName object itemType))) (COND (itemName (LET* ([methods (SORT (MASTERSCOPE `(WHO IN ',(_ self CollectMethodList object) CALLS ,itemName] [functions (SORT (MASTERSCOPE `(WHO IN ',(FILECOMSLST (@ selectedFile) 'FNS) CALLS ,itemName] (reportList (APPEND methods functions))) (* * Add an active menu for further interaction with the analysis.) (COND (reportList (SETQ reportList (NCONC1 (INTERSECTION reportList reportList) itemName)) (_ self AddAnalysisMenu reportList itemName itemType (CONCAT "Calls function " itemName))) (T (_ self PromptPrint (CONCAT itemType " " itemName " not called."))]) (Method ((FileBrowser CheckMenuItem) self item itemType itemName) (* ; "smL 12-Dec-86 13:33") "Check an item from an analysis menu for this browser." (SELECTQ itemType (SELECTOR (LET ((check-result (_ ($! item) MSCheck))) (if (NULL check-result) then (_ self PromptPrint (CONCAT "Method " item " is OK")) else (* MSCheck already printed out the  results) NIL))) (_ self PromptPrint (CONCAT "Check is not implemented for type " itemType)))) (Method ((FileBrowser CheckFile) self) (* ; "smL 11-Jun-86 16:28") "Do a MasterScope CHECK command on this file" (AND (_ self LoadMasterscope?) (EVAL.IN.TTY.CONTEXT `(PROGN (_ ,self ClearPromptWindow) (_ ,self PromptPrint "Checking...") [MASTERSCOPE '(CHECK ',(@ selectedFile)] (_ ,self PromptPrint "done checking.")) "Check file"))) (Method ((FileBrowser ComputeMenuItems) self reportList) (* ; "smL 12-Dec-86 13:17") "Creates list of items with appropriate subitems for use in the analysis menu." [for item in reportList collect (COND [(AND (FNTYP item) ($! item) (NEQ NotSetValue (@ ($! item) className))) (* Here for a method.) `(,item NIL NIL (SUBITEMS (Edit ,item) (Substitute ,item) (Check ,item] [(FNTYP item) (* Here for a function) `(,item NIL NIL (SUBITEMS (Edit ,item) (Substitute ,item] (T (* Here for a class.) `(,item NIL NIL (SUBITEMS (Edit ,item) (Substitute ,item]) (Method ((FileBrowser EditMenuItem) self item wait?) (* ; "smL 30-Oct-86 19:03") "New method template" [LET ((itemObject ($! item))) (COND [(AND (FNTYP item) itemObject (NEQ NotSetValue (@ itemObject className))) (* ;; "Here for editing a method.") (if wait? then (_ ($! (@ itemObject className)) EditMethod (@ itemObject selector)) else (ApplyMethodInTtyProcess ($! (@ itemObject className)) 'EditMethod (LIST (@ itemObject selector)] ((FNTYP item) (* ;; "Here for editing a function") (if wait? then (APPLY* 'DF item) else (EVAL.IN.TTY.CONTEXT `(DF ,item) "Edit item"))) (T (* ;; "Here for editing a class.") (if wait? then (_ ($! item) Edit) else (ApplyMethodInTtyProcess ($! item) 'Edit]) (Method ((FileBrowser ImplementsMethod) self object objectName) (* ; "smL 29-May-86 18:28") "Display menu of methods and classes that implement a method." [LET [(itemName (_ self SelectItemName object 'METHOD)] (COND (itemName (* ;  "Handle ANY special - user wants all methods on a file or in a class") (LET* [[methods (if (EQ itemName 'ANY) then (if (AND object (type? class ($! object))) then (for S in (_ ($! object) ListAttribute 'METHODS) collect (GetMethodOnly ($! object) S)) else (FILECOMSLST (@ selectedFile) 'METHODS)) else (* ;  "if it's a class and a specific itemname, it's max one method") (if (AND object (type? class ($! object))) then (LIST (FetchMethod ($! object) itemName)) else (MASTERSCOPE `(WHO IN (FILECOMSLST ',(@ selectedFile) 'METHODS) IMPLEMENTS ',itemName] (classes (for class in (OR (FILECOMSLST (@ selectedFile) 'CLASSES) (MKLIST object)) when (MEMB (FetchMethod ($! class) itemName) methods) collect ($! class] (* ;;; "Add an active menu for further interaction with the analysis.") (COND ((OR methods classes) (_ self AddAnalysisMenu (APPEND (SORT methods) (SORT (INTERSECTION classes classes))) itemName 'METHOD (CONCAT "Implements method " itemName))) (T (_ self PromptPrint (CONCAT " " itemName " not used as a " 'METHOD))]) (Method ((FileBrowser OverridesMethod) self object objectName) (* ; "smL 15-Jan-87 17:07") "Analyze file for methods that override a given message" [LET [(itemName (_ self SelectItemName object 'METHOD)] (COND (itemName (LET* [[methods (INTERSECTION [if (AND object (type? class ($! object))) then (MKLIST (FetchMethod ($! object) itemName)) else '(FILECOMSLST (@ selectedFile) 'METHODS] (MASTERSCOPE `(WHO OVERRIDES ',itemName] (classes (for class in (OR (FILECOMSLST (@ selectedFile) 'CLASSES) (MKLIST object)) when (MEMB (FetchMethod ($! class) itemName) methods) collect ($! class] (* * Add an active menu for further interaction with the analysis.) (COND ((OR methods classes) (_ self AddAnalysisMenu (APPEND (SORT methods) (SORT (INTERSECTION classes classes))) itemName 'METHOD (CONCAT "Overrides method " itemName))) (T (_ self PromptPrint (CONCAT " " itemName " is never overridden"))]) (Method ((FileBrowser SelectItemName) self object itemType) (* ; "smL 11-Apr-86 15:07") "Prompt user for the name of an item (IV, CV, selector, etc.) -- either from the selected class or from any class in the browser." (AND (_ self LoadMasterscope?) (LET* [(itemNames (SELECTQ itemType (FUNCTION (SORT (for fn in [MASTERSCOPE `(WHO IS CALLED BY ANY IN ',(_ self CollectMethodList object)] bind [knownFns _ (for file in FILELST join (FILECOMSLST file 'FNS] collect fn when (MEMB fn knownFns)))) (LISPVAR (SORT (for var in [MASTERSCOPE `(WHO IS USED BY ANY IN ',(_ self CollectMethodList object)] collect var))) (OBJECT (SORT (for obj in [MASTERSCOPE `(WHAT OBJECT IN (UNION (FILECOMSLST (@ selectedFile) 'CLASSES) (FILECOMSLST (@ selectedFile) 'INSTANCES)) IS USED BY ANY IN ',(_ self CollectMethodList object)] collect obj))) ((IV CV METHOD SELECTOR) [COND [object (_ object ListAttribute! (PACK* itemType 'S))] (T (for class in (FILECOMSLST (@ selectedFile) 'CLASSES) join (_ ($! class) ListAttribute! (PACK* itemType 'S))]) NIL)) (chosenName (MENU (create MENU TITLE _ (CONCAT "Which " itemType " ?") ITEMS _ (CONS '*other* (CONS '*any* (SORT (INTERSECTION itemNames itemNames] (SELECTQ chosenName (*other* (_ self PromptRead (CONCAT itemType " Name: "))) (*any* 'ANY) chosenName)))) (Method ((FileBrowser SendsMessage) self object objectName) (* ; "FBF 9-Apr-86 15:06") "Analyze file for methods that send a given message" [LET* ((itemType 'SELECTOR) (itemName (_ self SelectItemName object itemType))) (COND (itemName (LET* [(methods (SORT (MASTERSCOPE `(WHO IN ',(_ self CollectMethodList object) SENDS ,itemName] (* * Add an active menu for further interaction with the analysis.) (COND (methods (_ self AddAnalysisMenu methods itemName itemType (CONCAT "Sends message " itemName))) (T (_ self PromptPrint (CONCAT " " itemName " not used as a " itemType))]) (Method ((FileBrowser SpecializesMethod) self object objectName) (* ; "smL 15-Jan-87 17:08") "Display menu of methods and classes that specialize a method." [LET [(itemName (_ self SelectItemName object 'METHOD)] (COND (itemName (LET* [[methods (INTERSECTION [if (AND object (type? class ($! object))) then (MKLIST (FetchMethod ($! object) itemName)) else '(FILECOMSLST (@ selectedFile) 'METHODS] (MASTERSCOPE `(WHO SPECIALIZES ',itemName] (classes (for class in (OR (FILECOMSLST (@ selectedFile) 'CLASSES) (MKLIST object)) when (MEMB (FetchMethod ($! class) itemName) methods) collect ($! class] (* * Add an active menu for further interaction with the analysis.) (COND ((OR methods classes) (_ self AddAnalysisMenu (APPEND (SORT methods) (SORT (INTERSECTION classes classes))) itemName 'METHOD (CONCAT "Specializes method " itemName))) (T (_ self PromptPrint (CONCAT " " itemName " is never specialized"))]) (Method ((FileBrowser SubstituteMenuItem) self item itemType oldAtom newAtom) (* ; "smL 8-Apr-87 16:48") "Substitute and edit an item from an analysis menu for this browser." (* ;; "Only implemented properly for functions") (OR oldAtom (SETQ oldAtom (_ self PromptForWord "(Substitute) oldAtom: "))) (if (GETD item) then [MASTERSCOPE `(EDIT WHERE ',item ,@(SELECTQ itemType (IV '(USES THE IV)) (CV '(USES THE CV)) (OBJECT '(USES THE OBJECT)) (FUNCTION '(CALLS)) ((SELECTOR METHOD) '(SENDS)) (LISPVAR '(USES THE VAR)) (LoopsHelp itemType " not understood in SubstituteMenuItem ")) ,oldAtom - (R ,oldAtom ,(OR newAtom (_ self PromptForWord "(Substitute) newAtom: ") ] elseif (type? class item) then (SELECTQ itemType (IV (RenameVariable (_ item ClassName) oldAtom newAtom)) (CV (RenameVariable (_ item ClassName) oldAtom newAtom T)) ((SELECTOR METHOD) (_ item RenameMethod oldAtom newAtom)) ((OBJECT FUNCTION LISPVAR) NIL) (LoopsHelp itemType " not understood in SubstituteMenuItem "))) (_ self EditMenuItem item T)) (Method ((FileBrowser UsesCV) self object objectName) (* ; "mjs: 4-Dec-85 09:52") "Analyze file for methods and classes that use a given CV" (_ self UsesItem object objectName 'CV)) (Method ((FileBrowser UsesIV) self object objectName) (* ; "mjs: 4-Dec-85 09:13") "Analyze file for methods and classes that use a given IV." (_ self UsesItem object objectName 'IV)) (Method ((FileBrowser UsesItem) self object objectName itemType) (* ; "smL 15-Jan-87 17:01") "Generalized method (for IVS, CVS, OBJECTS, MESSAGES) for interaction about MASTERSCOPE analysis." [LET ((itemName (_ self SelectItemName object itemType))) (COND (itemName (LET* [[methods (SORT (MASTERSCOPE (SELECTQ itemName (ANY `(WHO IN ',(_ self CollectMethodList object) USES ANY ,itemType)) `(WHO IN ',(_ self CollectMethodList object) USES THE ,itemType ,itemName] [classes (COND (object (LIST object)) ((EQ itemType 'OBJECT) NIL) (T (SORT (for class in (FILECOMSLST (@ selectedFile) 'CLASSES) when [MEMB itemName (_ ($! class) ListAttribute (PACK* itemType 'S))] collect ($! class] (reportList (COND ((OR methods classes) (APPEND methods classes] (* * Add an active menu for further interaction with the analysis.) (COND (reportList (_ self AddAnalysisMenu reportList itemName itemType (CONCAT "Uses " itemName " as a " itemType))) ((EQ itemName 'ANY) (_ self PromptPrint (CONCAT " " "Nobody uses any " itemType "s"))) (T (_ self PromptPrint (CONCAT " " itemName " not used as a " itemType))]) (Method ((FileBrowser UsesLispVar) self object objectName) (* ; "mjs: 10-Dec-85 09:47") "Analyze file for methods that and functions use a given lisp variable" [LET* ((itemType 'LISPVAR) (itemName (_ self SelectItemName object itemType))) (COND (itemName (LET* ([methods (SORT (MASTERSCOPE `(WHO IN ',(_ self CollectMethodList object) USES ,itemName] [functions (SORT (MASTERSCOPE `(WHO IN ',(FILECOMSLST (@ selectedFile) 'FNS) USES ,itemName] (reportList (APPEND methods functions))) (* * Add an active menu for further interaction with the analysis.) (COND (reportList (SETQ reportList (INTERSECTION reportList reportList)) (_ self AddAnalysisMenu reportList itemName itemType (CONCAT "Uses Lisp Var " itemName))) (T (_ self PromptPrint (CONCAT itemType " " itemName " not used."))]) (Method ((FileBrowser UsesObject) self object objectName) (* ; "smL 16-Dec-85 17:30") "Analyze file for methods and classes that use a given Object." (_ self UsesItem object objectName 'OBJECT)) (\UnbatchMethodDefs) (DEFINEQ (UsesMenuWhenSelectedFn [LAMBDA (item menu key) (* ; "Edited 13-Aug-90 15:24 by jds") (* ;;; "WhenSelectedFn for interactive menus created by MasterScope analysis requests from browser.") (* ;;; "JRB Instead of rolloffs, this menu pops up a submenu of apropos options - the rolloff for *EditAll* is handled with a crufty hack.") (ALLOW.BUTTON.EVENTS) (LET [(browser (WINDOWPROP (WFROMMENU menu) 'LoopsFileBrowser)) (itemName (GETMENUPROP menu 'itemName)) (itemType (GETMENUPROP menu 'itemType] (AND (LISTP item) (SETQ item (CAR item))) (SELECTQ item (*EditAll* (for menuItem in (fetch (MENU ITEMS) of menu) unless (LISTP menuItem) do (_ browser EditMenuItem menuItem T))) (*SubstituteAll* (LET ((newAtom (_ browser PromptForWord "(Substitute) newAtom: "))) (for menuItem in (fetch (MENU ITEMS) of menu) unless (LISTP menuItem) do (_ browser SubstituteMenuItem menuItem itemType itemName newAtom)))) (SELECTQ [MENU (create MENU TITLE _ item ITEMS _ (if (AND (FNTYP item) ($! item) (NEQ NotSetValue (@ ($! item) className))) then '(Edit Substitute Check) else '(Edit Substitute] (Edit (_ browser EditMenuItem item T)) (Substitute (_ browser SubstituteMenuItem item itemType itemName)) (Check (_ browser CheckMenuItem item itemType itemName)) NIL]) ) (* ;;; "Instance browser") (\BatchMethodDefs) (METH InstanceBrowser GetSubs (object) "Gets a set of subs from an object for browsing." (category (LatticeBrowser))) (METH InstanceBrowser NewPath (subName) "Changes the name of the sub by which the lattice is computed, changes the title, and recomputes the graph" (category (InstanceBrowser))) (Method ((InstanceBrowser GetSubs) self object) (* ; "dgb: 19-SEP-83 17:12") "Gets a set of subs from an object for browsing." [COND ((AND (@ subIV) (_ object HasIV (@ subIV))) (* If the object has an IV named in (@ subIV) and that is an IV of object, then  use that for following links) (GetValue object (@ subIV)]) (Method ((InstanceBrowser NewPath) self subName) (* ; "dgb: 19-SEP-83 17:31") "Changes the name of the sub by which the lattice is computed, changes the title, and recomputes the graph" (PROG NIL [COND ((NULL subName) (OR (SETQ subName (PromptRead "Name of new IV for browsing: ")) (RETURN] (_@ subIV subName) (_@ title (CONCAT subName " instance browser")) (AND (_ self HasLispWindow) (_ self Recompute)))) (\UnbatchMethodDefs) (* ;;; "Supers browser") (\BatchMethodDefs) (METH SupersBrowser GetSubs (object objName) "Returns local supers" (category (LatticeBrowser))) (Method ((SupersBrowser GetSubs) self object objName) (* ; "smL 2-Jan-86 16:36") "Returns local supers" (fetch localSupers of object)) (\UnbatchMethodDefs) (* ;;; "Meta browser") (\BatchMethodDefs) (METH MetaBrowser GetSubs (elt) "Subs for meta browser is the meta class of the class." (category (LatticeBrowser))) (Method ((MetaBrowser GetSubs) self elt) (* ; "smL 11-Apr-86 14:59") "Subs for meta browser is the meta class of the class." [PROG [(meta (GetObjectRec (CAR (_ (GetObjectRec elt) ListAttribute 'Meta)] (RETURN (COND ((EQ meta (GetObjectRec elt)) NIL) (T (CONS meta]) (\UnbatchMethodDefs) (DECLARE%: DONTEVAL@LOAD DOEVAL@COMPILE DONTCOPY COMPILERVARS (ADDTOVAR NLAMA ) (ADDTOVAR NLAML LispxSend) (ADDTOVAR LAMA ) ) (PUTPROPS LOOPSBROWSE COPYRIGHT ("Venue & Xerox Corporation" 1983 1984 1985 1986 1987 1988 1990 1991 2022)) (DECLARE%: DONTCOPY (FILEMAP (NIL (86929 123910 (AddMenuWindow 86939 . 88764) (BoxPrintString 88766 . 96413) ( BoxWindowNode 96415 . 97133) (BreakStringForBoxing 97135 . 100532) (Browse 100534 . 101039) ( ClearCache 101041 . 101750) (DoMenuMethod 101752 . 101967) (DualMenu 101969 . 102424) (DualSelection 102426 . 103634) (DualSubItems 103636 . 104923) (FILECLASSES 104925 . 105060) (FileBrowse 105062 . 105221) (FindSelectedNode 105223 . 106984) (FunctionMenuWhenSelectedFn 106986 . 107512) (ItemsForType 107514 . 108002) (LatticeBrowser.ButtonFn 108004 . 108828) (LatticeBrowser.WhenHeldFn 108830 . 109940) (LatticeBrowserExpandFn 109942 . 110262) (LatticeBrowserIconButtonEventFn 110264 . 110724) (LispxSend 110726 . 111148) (Menu-Group-Size 111150 . 111364) (Repaint-Menu-Window 111366 . 111874) ( SubItemSelection 111876 . 112886) (TreeRoots 112888 . 116064) (ReachableNodes! 116066 . 116778) ( ChildNodes 116780 . 117104) (\DeleteSubtree 117106 . 117651) (\Menu-Group-Size 117653 . 119721) ( \Place-Menu-Group-In-Window 119723 . 122958) (\PortableGraphNodeID 122960 . 123450) ( \Remove-Menu-Group-From-Window 123452 . 123908)) (160869 163011 (ClassBrowserMarkChanged 160879 . 162144) (UpdateClassBrowsers 162146 . 163009)) (163096 163225 (UpdateClassBrowsers? 163096 . 163225)) (163227 163342 (WithCategories 163227 . 163342)) (187299 188406 (FileBrowserMarkChanged 187309 . 188404)) (217070 219116 (UsesMenuWhenSelectedFn 217080 . 219114))))) STOP