(DEFINE-FILE-INFO PACKAGE "IL" READTABLE "INTERLISP" BASE 10) (FILECREATED " 8-Jul-88 20:33:57"  |{POGO:AISNORTH:XEROX}LYRIC>USERS>RULES>LOOPSRULES-ROOT.;13| 14260 changes to%: (METHODS Class.DefRSM) previous date%: "17-Jun-88 17:26:33" |{POGO:AISNORTH:XEROX}LYRIC>USERS>RULES>LOOPSRULES-ROOT.;12|) (* " Copyright (c) 1988 by XEROX Corporation. All rights reserved. ") (PRETTYCOMPRINT LOOPSRULES-ROOTCOMS) (RPAQQ LOOPSRULES-ROOTCOMS ((DECLARE%: DONTCOPY (PROP MAKEFILE-ENVIRONMENT LOOPSRULES-ROOT)) (COMS (* ; "Override a few basic fns in Loops") (FNS MoveMethod) (METHODS Class.CopyMethod Class.DefRSM Class.EditMethod Class.PPMethod)) (COMS (* ;  "Patch the class brower menus to add DefRSM") (FNS AddDefRSMtoClassBrowser)) (COMS (* ; "Load the Rules files") (FILES (FROM VALUEOF LOOPSUSERSDIRECTORY) LOOPSBACKWARDS LOOPSMIXIN) (FILES (FROM VALUEOF LOOPSUSERSRULESDIRECTORY) LOOPSRULES LOOPSRULESP LOOPSRULESC LOOPSRULESD LOOPSRULESTTY )) (P (AddDefRSMtoClassBrowser)) (PROP MAKEFILE-ENVIRONMENT LOOPSRULES-ROOT))) (DECLARE%: DONTCOPY (PUTPROPS LOOPSRULES-ROOT MAKEFILE-ENVIRONMENT (:PACKAGE "IL" :READTABLE "INTERLISP" :BASE 10)) ) (* ; "Override a few basic fns in Loops") (DEFINEQ (MoveMethod [LAMBDA (oldClassName newClassName selector newSelector files) (* ; "Edited 17-Jun-88 17:21 by raf") (* ;;; "Move a method from oldClassName to newClassName, renaming function if appropriate") (SETQ oldClassName (GoodClassName oldClassName NIL T)) (OR newClassName (SETQ newClassName oldClassName)) (SETQ newClassName (GoodClassName newClassName NIL T)) (OR newSelector (SETQ newSelector selector)) (PROG (oldDef newLocalFn delFnFlg oldRuleSetName oldRuleSet newRuleSetName newRuleSet methodType (oldClass (GetClassRec oldClassName)) (newClass (GetClassRec newClassName)) (localFn (FindLocalMethod (GetClassRec oldClassName) selector))) (* ;; "Punt now for null moves") (if (AND (EQ oldClass newClass) (EQ selector newSelector)) then (RETURN NIL)) (COND ((NULL localFn) (printout T selector " not found in " oldClassName) (RETURN NIL)) [(STRPOS oldClassName localFn) (OR (SETQ oldDef (GETDEF localFn 'METHOD-FNS)) (ERROR "No defintion found for " localFn)) (* ;  "Remember to delete fn def Dont use DELDEF since it bitches.") (SETQ delFnFlg T) (COND [[ValueFound (SETQ oldRuleSetName (GetMethod oldClass selector 'RuleSet] (* ;  "Treat specially those that are implemented by RuleSets.") (LET* ((oldRuleSet (GetObjectRec oldRuleSetName)) (newRuleSetName (MethName (ClassName newClass) selector)) (newRuleSet (_ oldRuleSet CopyRules newRuleSetName newClass))) (SETQ newLocalFn (DefRSM newClass selector newRuleSetName] (T (* ; "Define the method") (SETQ newLocalFn (EVAL (CL:MULTIPLE-VALUE-BIND (cname sel args decls formsd doc quals method-type) (PARSE-METHOD-BODY oldDef) (PACK-METHOD-BODY newClassName newSelector args decls formsd doc quals method-type] (T (AddMethod newClass newSelector localFn))) (for prop in (DREMOVE 'RuleSet (_ oldClass ListAttribute 'Method selector)) do (PutMethodOnly newClass newSelector (GetMethodOnly oldClass selector prop) prop)) (DeleteMethod oldClass selector delFnFlg) (RETURN (OR newLocalFn localFn]) ) (\BatchMethodDefs) (METH Class CopyMethod (selector newClass newSelector) "Copy method from self to newClass. newSelector defaults to selector" (category (Class))) (METH Class DefRSM (selector) "Installs a RuleSet as a method in the class. If ruleSetName is NIL, then DefRSM creates a RuleSet, invokes the RuleSet editor, compiles the RuleSet, and installs it as a method in the class. Also initializes the workspace instance variable." (category (Class))) (METH Class EditMethod (selector commands) "Called by Class.EditMethod. Finds the function associated with selector in class, and calls editor on it" (category (Class))) (METH Class PPMethod (selector) "Prettyprint the function which implements selector in this class." (category (Class))) (Method ((Class CopyMethod) self selector newClass newSelector) (* ; "RBGMartin 13-Oct-87 17:10") "Copy method from self to newClass. newSelector defaults to selector" (OR newSelector (SETQ newSelector selector)) (LET (def newFn oldRuleSetName (myMethName (FindLocalMethod (GetClassRec self) selector))) [COND ((NULL myMethName) (COND ((SETQ myMethName (FetchMethod self selector)) (HELPCHECK selector " is not local for " self " To copy anyway, type OK")) (T (ERROR selector (CONCAT "is not a selector for " self] [OR (type? class newClass) (SETQ newClass (OR (GetClassRec newClass) (AND (HELPCHECK newClass " is not a class. Type OK to use oldClass: ") self] [COND [[ValueFound (SETQ oldRuleSetName (GetMethod self selector 'RuleSet] (* ;  "Treat specially those that are implemented by RuleSets.") (LET* ((oldRuleSet (GetObjectRec oldRuleSetName)) (newRuleSetName (MethName (ClassName newClass) selector)) (newRuleSet (_ oldRuleSet CopyRules newRuleSetName newClass))) (SETQ newFn (DefRSM newClass selector newRuleSetName] (T (* ; "Define the method") (OR (SETQ def (GETDEF myMethName 'METHOD-FNS)) (ERROR myMethName " is not a defined function")) (SETQ newFn (EVAL (CL:MULTIPLE-VALUE-BIND (cname sel args decls forms doc quals type) (PARSE-METHOD-BODY def) (PACK-METHOD-BODY (ClassName newClass) newSelector args decls forms doc quals type] (for prop in (DREMOVE 'RuleSet (_ self ListAttribute 'Method selector)) do (* ; "Copy all the properties") (PutMethod newClass newSelector (GetMethod self selector prop) prop)) newFn)) (Method ((Class DefRSM) self selector) (* ; "dgb: 9-NOV-83 11:20") "Installs a RuleSet as a method in the class. If ruleSetName is NIL, then DefRSM creates a RuleSet, invokes the RuleSet editor, compiles the RuleSet, and installs it as a method in the class. Also initializes the workspace instance variable." (DefRSM self selector)) (Method ((Class EditMethod) self selector commands) (* ; "RBGMartin 17-Feb-87 16:34") "Called by Class.EditMethod. Finds the function associated with selector in class, and calls editor on it" [LET* [[selector (OR selector (_ self PickSelector (CONCAT "EditMethod: " (ClassName self)))] (method (AND selector (FindLocalMethod self selector] [if (NULL selector) then NIL elseif (NULL method) then (LET [(allSelectors (_ self ListAttribute! 'Selectors)] (if (MEMB selector allSelectors) then (* ; "The method is an inherited one") (if (EQ 'Y (ASKUSER NIL NIL (CONCAT selector " is not a local method of " self ". Should I make it local for editing? " ))) then (SETQ method (_ self MakeLocalMethod selector))) else (LET* [(containingForm (if (AND (BOUNDP '\SendForm) (EQ \Obj self) (EQ \Selector 'EditMethod)) then \SendForm)) (correctedSelector (\LoopsFixSpell selector allSelectors (CONS '_ containingForm) (if (EQ 'QUOTE (CAR (CADDR containingForm))) then (CDR (CADDR containingForm] (if correctedSelector then (SETQ selector correctedSelector) (SETQ method (OR (FindLocalMethod self correctedSelector) (_ self MakeLocalMethod correctedSelector)] (LET [(ruleSet (AND method (GetMethod self selector 'RuleSet] (if (NULL method) then NIL elseif (ValueFound ruleSet) then (* ;  "Here if the method is implemented by a RuleSet.") (_ (GetObjectRec ruleSet) EditRules) elseif (NULL (CheckMethodForm self selector method)) then (PROMPTPRINT method " is not a known function.") else (if (GETDEF method 'METHOD-FNS NIL '(NOERROR NOCOPY NODWIM)) then (EDITDEF method 'METHOD-FNS NIL commands) else (PROMPTPRINT "Can't find source for " method T) NIL]) (Method ((Class PPMethod) self selector) (* ; "smL 9-Apr-87 19:18") (* ;;; "Prettyprint the function which implements selector in this class.") (* ;;; "") [LET [(selector (OR selector (_ self PickSelector (CONCAT "PPMethod: " (ClassName self)))] (COND (selector (LET ((fn (_ self FetchMethod selector)) (outFile (PPDefault NIL))) (if fn then [RESETFORM (OUTPUT outFile) (WITH.PP.OUTPUT outFile (TERPRI outFile) (PRINTDEF (GETDEF fn 'METHOD-FNS] else (PRINTOUT outFile "No method for selector " selector " in " self T]) (\UnbatchMethodDefs) (* ; "Patch the class brower menus to add DefRSM") (DEFINEQ (AddDefRSMtoClassBrowser [LAMBDA NIL (* ; "Edited 16-Dec-87 12:23 by jrb:") (PROG [(MIDDLEITEMS (GetClassValue ($ ClassBrowser) 'MiddleButtonItems] [PutClassValue ($ ClassBrowser) 'MiddleButtonItems (for N in MIDDLEITEMS collect (COND [(EQUAL (CAR N) "Add (AddMethod)") (LET ((SUBITEMFORM (CADR N))) (LIST (CAR N) (LIST (CAR SUBITEMFORM) (LSUBST '(("AddMethod" AddNewMethod "Add a new method to the class") ("DefRSM" DefRSM "Add a new ruleset method to the class")) '("AddMethod" AddNewMethod "Add a new method to the class") (CADADR N)) (CADDR SUBITEMFORM)) (CADDR N] (T N] (ClearAllCaches]) ) (* ; "Load the Rules files") (FILESLOAD (FROM VALUEOF LOOPSUSERSDIRECTORY) LOOPSBACKWARDS LOOPSMIXIN) (FILESLOAD (FROM VALUEOF LOOPSUSERSRULESDIRECTORY) LOOPSRULES LOOPSRULESP LOOPSRULESC LOOPSRULESD LOOPSRULESTTY) (AddDefRSMtoClassBrowser) (PUTPROPS LOOPSRULES-ROOT MAKEFILE-ENVIRONMENT (:PACKAGE "IL" :READTABLE "INTERLISP" :BASE 10)) (PUTPROPS LOOPSRULES-ROOT COPYRIGHT ("XEROX Corporation" 1988)) (DECLARE%: DONTCOPY (FILEMAP (NIL (1881 4966 (MoveMethod 1891 . 4964)) (12398 13809 (AddDefRSMtoClassBrowser 12408 . 13807 ))))) STOP