(DEFINE-FILE-INFO READTABLE "INTERLISP" PACKAGE "INTERLISP") (FILECREATED "15-Aug-90 13:17:56" {DSK}local>lde>SOURCES>loops>SYSTEM>LOOPSUSERINTERFACE.;2 15894 changes to%: (VARS LOOPSUSERINTERFACECOMS) previous date%: "29-Feb-88 10:32:58" {DSK}local>lde>SOURCES>loops>SYSTEM>LOOPSUSERINTERFACE.;1) (* ; " Copyright (c) 1986, 1987, 1988, 1990 by Venue & Xerox Corporation. All rights reserved. ") (PRETTYCOMPRINT LOOPSUSERINTERFACECOMS) (RPAQQ LOOPSUSERINTERFACECOMS ((* * Support for ?= and methods) (FNS GetMethodArgs) (VARS (TTYIN?=FN 'GetMethodArgs)) (* * Add a Loops item to the background menu) [ADDVARS (BackgroundMenuCommands ("Loops Icon" '(_Proto ($ LoopsIcon) Blink) "Bring the Loops Icon to the top of the screen" (SUBITEMS ("Browse Class" '(_Proto ($ LoopsIcon) BrowseObject) "Prompts for a class name and opens a browser on the class" (SUBITEMS ("Browse Class" '(_Proto ($ LoopsIcon) BrowseObject) "Prompts for a class name and opens a browser on the class" ) ("Browse Supers" '(_Proto ($ LoopsIcon) SupersBrowse) "Prompts for a class name and opens a browser on the class's supers" ))) ("Browse File" '(_Proto ($ LoopsIcon) FileBrowse) "Opens a Loops FileBrowser on a selected file" (SUBITEMS ("Browse File" '(_Proto ($ LoopsIcon) FileBrowse) "Opens a Loops FileBrowser on a selected file" ) ("Edit FileComs" '(_Proto ($ LoopsIcon) EditFileComs) "Edit the FILECOMS of a selected file") ("Cleanup File" '(_Proto ($ LoopsIcon) CleanUpFile) "Do a CLEANUP on a selected file"] (VARS (BackgroundMenu NIL)) (* * The PPDefault window) (VARS (PPDefault \TopLevelTtyWindow)) (GLOBALVARS PPDefault))) (* * Support for ?= and methods) (DEFINEQ (GetMethodArgs [LAMBDA (fn) (* ; "Edited 25-Nov-87 11:57 by Bane") (* ;;; "Used in the TTYIN function when the user types in ?=") (SELECTQ fn ((_ _Super _New _Proto _Process SEND) (* ;; "Try to find the arguments to a message") (PROG (obj sel class actuals) (* ;; "Parse the message") (SETQ actuals (TTYIN.READ?=ARGS)) (if (NULL actuals) then (RETURN)) (SETQ obj (CAR actuals)) (SETQ sel (CADR actuals)) (* ;; "Try to compute the class of the object that will receive the message") [SETQ class (LET [(evalObj (COND ((Object? obj) (* ;  "If the obj form is alread any object, the value of the obj form will still be that object") obj) [(ATOM obj) (* ;  "An atom can be evaluated safely with no side effects") (CAR (NLSETQ (EVAL obj] ((NOT (LISTP obj)) (* ;  "God knows what to do if the form isn't an object, an atom, or a list") NIL) ((EQ '$ (CAR obj)) (* ;  "The form ($ name) can be evaluated safely with no side effects") (EVAL obj)) ((AND (EQ '$! (CAR obj)) (ATOM (CADR obj))) (* ;  "The form ($! litatom) can be evaluated safely with no side effects") (EVAL obj)) ((AND (EQLENGTH obj 1) (EQ (CAR obj) 'SavedValue)) (* ;  "The form (SavedValue) can be evaluated safely with no side effects") (EVAL obj] (COND ((MEMB fn '(_New _Proto)) evalObj) ((AND (Object? evalObj) (NEQ ($ Tofu) (Class evalObj))) (Class evalObj)) (T (GetClassRec (OR (PromptRead (CONCAT (CHARACTER 7) (CHARACTER (CHARCODE CR)) "Please type in name of class for " obj (CHARACTER (CHARCODE CR)) "or type ] to evaluate expression to find class" )) (Class (EVAL obj] (COND ((NULL class) (RETURN))) (* ;; "If the user has not provided a selector, let her pick one") [COND ((NULL sel) [SETQ sel (MENU (LET ((selectors! (_ class ListAttribute! 'Selectors NIL T))) (COND [(LEQ (LENGTH selectors!) 10) (create MENU TITLE _ "Which selector?" ITEMS _ selectors! MENUCOLUMNS _ (ADD1 (IQUOTIENT (ITIMES (FONTHEIGHT MENUFONT) (LENGTH selectors!)) 500] (T (LET* [(localSelectors (_ class ListAttribute 'Selectors)) [genericSelectors (LDIFFERENCE selectors! (_ class ListAttribute! 'Selectors)] (inheritedSelectors (LDIFFERENCE selectors! (UNION genericSelectors localSelectors))) (columns (ADD1 (IQUOTIENT (ITIMES (FONTHEIGHT MENUFONT) (PLUS 2 (LENGTH localSelectors))) 500] (* ;;  "ListAttribute! does the wrong thing in these cases, so swap the two sub-selector menus") (SELECTQ (ClassName class) ((Class Object Tofu) (CL:PSETQ inheritedSelectors genericSelectors genericSelectors inheritedSelectors)) NIL) (* ;  "We have to go to some length to make sure that items with sub-items are in the right hand column") (create MENU TITLE _ "Which selector?" ITEMS _ [if (OR (EQP 1 columns) (AND (NULL genericSelectors) (NULL inheritedSelectors))) then `[,@localSelectors ["*generics*" NIL NIL (SUBITEMS ,@(SORT genericSelectors ] ("*inherited*" NIL NIL (SUBITEMS ,@(SORT inheritedSelectors ] else (LET ((dummyItem (LIST "" NIL NIL))) `(,@localSelectors ,@(from (ADD1 (REMAINDER (LENGTH localSelectors) columns)) to (SUB1 columns) collect dummyItem) ["*generics*" NIL NIL (SUBITEMS ,@(SORT genericSelectors ] ,@(from 1 to (SUB1 columns) collect dummyItem) ("*inherited*" NIL NIL (SUBITEMS ,@(SORT inheritedSelectors ] MENUCOLUMNS _ columns] (* ;  "Save the user the effort of having to type in the selector just chosen") (COND (sel (BKSYSBUF sel] (COND ((NULL sel) (RETURN))) (* ;; "Print out information about the message") [LET ((meth (FetchMethod class sel))) (COND (meth (PROMPTPRINT (@ ($! meth) doc)) (LET ((arglist (ARGLIST meth))) (TTYIN.PRINTARGS fn `(,(CAR arglist) Method ., (CDR arglist)) `(,obj ,meth ., (CDDR actuals)) 0)) (RETURN T] (RETURN NIL))) ((create CREATE Create) (* ;; "Tell the user the field names of the record. --- This code is taken from Thomas G. Dietterich, tgd@oregon-stant.CSNet --- Thanks, wherever you are Tom.") [PROG (fieldNames recName (soFar (TTYIN.READ?=ARGS))) (SETQ recName (CAR soFar)) (COND (recName (SETQ fieldNames (RECORDFIELDNAMES recName)) (COND (fieldNames (RETURN (REVERSE fieldNames]) NIL]) ) (RPAQQ TTYIN?=FN GetMethodArgs) (* * Add a Loops item to the background menu) (ADDTOVAR BackgroundMenuCommands ["Loops Icon" '(_Proto ($ LoopsIcon) Blink) "Bring the Loops Icon to the top of the screen" (SUBITEMS ("Browse Class" '(_Proto ($ LoopsIcon) BrowseObject) "Prompts for a class name and opens a browser on the class" (SUBITEMS ("Browse Class" '(_Proto ($ LoopsIcon) BrowseObject) "Prompts for a class name and opens a browser on the class" ) ("Browse Supers" '(_Proto ($ LoopsIcon) SupersBrowse) "Prompts for a class name and opens a browser on the class's supers" ))) ("Browse File" '(_Proto ($ LoopsIcon) FileBrowse) "Opens a Loops FileBrowser on a selected file" (SUBITEMS ("Browse File" '(_Proto ($ LoopsIcon) FileBrowse) "Opens a Loops FileBrowser on a selected file") ("Edit FileComs" '(_Proto ($ LoopsIcon) EditFileComs) "Edit the FILECOMS of a selected file") ("Cleanup File" '(_Proto ($ LoopsIcon) CleanUpFile) "Do a CLEANUP on a selected file"]) (RPAQQ BackgroundMenu NIL) (* * The PPDefault window) (RPAQ PPDefault \TopLevelTtyWindow) (DECLARE%: DOEVAL@COMPILE DONTCOPY (GLOBALVARS PPDefault) ) (PUTPROPS LOOPSUSERINTERFACE COPYRIGHT ("Venue & Xerox Corporation" 1986 1987 1988 1990)) (DECLARE%: DONTCOPY (FILEMAP (NIL (3269 13444 (GetMethodArgs 3279 . 13442))))) STOP