(DEFINE-FILE-INFO READTABLE "XCL" PACKAGE "INTERLISP")

(FILECREATED "11-May-93 13:18:13" |{DSK}<usr>local>lde>loops>users>rules>RULES-ROOT.;2|
 16621  

      |changes| |to:|  (VARS RULES-ROOTCOMS)

      |previous| |date:| "11-May-93 12:42:46" |{DSK}<usr>local>lde>loops>users>rules>RULES-ROOT.;1|
)


; Copyright (c) 1993 by Venue.  All rights reserved.

(PRETTYCOMPRINT RULES-ROOTCOMS)

(RPAQQ RULES-ROOTCOMS

       ((DECLARE\: DONTCOPY (PROP MAKEFILE-ENVIRONMENT RULES-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)
                     RULES RULESP RULESC RULESD RULESTTY))
        (P (|AddDefRSMtoClassBrowser|))
        (PROP MAKEFILE-ENVIRONMENT RULES-ROOT)))
(DECLARE\: DONTCOPY 
)



(* \; "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)
       RULES RULESP RULESC RULESD RULESTTY)

(|AddDefRSMtoClassBrowser|
)
(PUTPROPS RULES-ROOT COPYRIGHT ("Venue" 1993))
(DECLARE\: DONTCOPY
  (FILEMAP (NIL (1497 5240 (|MoveMethod| 1507 . 5238)) (14455 16295 (|AddDefRSMtoClassBrowser| 14465 . 
16293)))))
STOP